'---mdlMkShortcut----------------------------------------------------------------------------------------------------------------------- Option Compare Database Option Explicit Function MkShortcut(ByVal wFile As String, ByVal ShortcutName As String) As Boolean '依頼ファイルのショートカットを作成 '成功=True Dim objWSH As Object Dim objShortcut As Object Dim strDesktopPath As String Dim strProgramsPath As String Dim wPath As String Dim wFileName As String On Error GoTo ErrTrap Set objWSH = CreateObject("WScript.Shell") 'デスクトップのパスを取得 strDesktopPath = objWSH.SpecialFolders("Desktop") strProgramsPath = objWSH.SpecialFolders("Programs") '依頼ファイルの格納先フォルダ取得 wPath = LsGetPath(wFile, wFileName) 'ショートカット名が指定されなければ If ShortcutName = "" Then ShortcutName = wFileName & "へのショートカット.lnk" If LCase(Right$(ShortcutName, 4)) <> ".lnk" Then ShortcutName = ShortcutName & ".lnk" 'デスクトップにショートカットを作成 Set objShortcut = objWSH.CreateShortcut(strDesktopPath & "\" & ShortcutName) GoSub MkSh 'スタートメニューのプログラムにショートカットを作成 Set objShortcut = objWSH.CreateShortcut(strProgramsPath & "\" & ShortcutName) GoSub MkSh MkShortcut = True ExitPoint: Exit Function MkSh: 'ショートカット情報設定と保存 With objShortcut Option Compare Database Option Explicit Function MkShortcut(ByVal wFile As String, ByVal ShortcutName As String) As Boolean '依頼ファイルのショートカットを作成 '成功=True Dim objWSH As Object Dim objShortcut As Object Dim strDesktopPath As String Dim strProgramsPath As String Dim wPath As String Dim wFileName As String Dim iExp As Integer On Error GoTo ErrTrap Set objWSH = CreateObject("WScript.Shell") 'デスクトップのパスを取得 strDesktopPath = objWSH.SpecialFolders("Desktop") strProgramsPath = objWSH.SpecialFolders("Programs") '依頼ファイルの格納先フォルダ取得 If iExp = 1 Then 'lnk wPath = LsGetPath(wFile, wFileName) End If 'ショートカット名が指定されなければ If ShortcutName = "" Then ShortcutName = wFileName & "へのショートカット.lnk" iExp = InStr(".lnk.url", LCase(Right$(ShortcutName, 4))) If iExp < 1 Then ShortcutName = ShortcutName & ".lnk" 'デスクトップにショートカットを作成 Set objShortcut = objWSH.CreateShortcut(strDesktopPath & "\" & ShortcutName) GoSub MkSh 'スタートメニューのプログラムにショートカットを作成 Set objShortcut = objWSH.CreateShortcut(strProgramsPath & "\" & ShortcutName) GoSub MkSh MkShortcut = True ExitPoint: Exit Function MkSh: 'ショートカット情報設定と保存 With objShortcut .TargetPath = objWSH.ExpandEnvironmentStrings(wFile) If iExp = 1 Then 'lnk .WorkingDirectory = objWSH.ExpandEnvironmentStrings(wPath) .WindowStyle = 4 .IconLocation = objWSH.ExpandEnvironmentStrings(wFile & ", 0") End If .Save End With Return ErrTrap: MsgBox Error Resume ExitPoint End Function Function LsGetPath(依頼ファイル As String, ファイル名 As String) As String '依頼ファイルのフルパスを返す。 ファイル名 = Dir$(依頼ファイル) LsGetPath = Left$(依頼ファイル, InStr(依頼ファイル, ファイル名) - 1) End Function '---mdlGetOpenFileName------------------------------------------------------------------------------------------------------- Option Compare Database Option Explicit Public Const MAX_PATH = 261 '「ファイルを開く」コモンダイアログを呼び出す Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Type OPENFILENAME lStructSize As Long 'この構造体の長さ hwndOwner As Long '呼び出し元ウインドウハンドル hInstance As Long 'モジュールのインスタンスハンドル lpstrFilter As String 'フィルタ文字列 lpstrCustomFilter As String 'ユーザー定義のフィルタ文字列のペア nMaxCustrFilter As Long 'lpstrCustomFilterのバッファサイズ nFilterIndex As Long 'フィルタコンボボックスの初期インデックス値 lpstrFile As String '選択されたファイル名のフルパス nMaxFile As Long 'lpstrFileのバッファサイズ lpstrFileTitle As String '選択されたファイル名のタイトル nMaxFileTitle As Long 'lpstrFileTitleのバッファサイズ lpstrInitialDir As String '初期フォルダ名 lpstrTitle As String 'ダイアログボックスのタイトル名 flags As Long '以下のFlagsの値の組み合わせ nFileOffset As Integer 'lpstrFileの最後の \までのオフセット値 nFileExtension As Integer '拡張子までのオフセット値 lpstrDefExt As String 'ファイル名の入力時、拡張子が省略された時の拡張子 lCustrData As Long 'OSがlpfnHookで指定されたフック関数に渡すアプリ定義のデータ lpfnHook As Long 'ダイアログに送られるメッセージを処理するフック関数のポインタ lpTemplateName As String End Type 'Flagsに設定する値 Public Const OFN_ALLOWMULTISELECT = &H200 'ファイル名リストボックスで複数選択を可能にする Public Const OFN_CREATEPROMPT = &H2000 '現在存在しないファイルを作成するかを確認する Public Const OFN_EXTENSIONDIFFERENT = &H400 'ファイル名の拡張子とlpstrDefExtで指定された拡張子が異なる Public Const OFN_FILEMUSTEXIST = &H1000 '既存のファイルだけ入力できるようにする Public Const OFN_HIDEREADONLY = &H4 '[読み取り専用]チェックボックスを表示しない Public Const OFN_NOCHANGEDIR = &H8 'ダイアログボックスを開いたときに現在のディレクトリを表示する Public Const OFN_NOREADONLYRETURN = &H8000 '読み取り専用属性を持たず、読み取り専用フォルダにないファイルを取得する Public Const OFN_NOVALIDATE = &H100 '無効な文字を含むファイル名を指定出来るようにする Public Const OFN_OVERWRITEPROMPT = &H2 '[ファイル名を付けて保存]ダイアログで選択したファイルが存在する場合の上書確認する Public Const OFN_PATHMUSTEXIST = &H800 '無効なパスを入力したときに警告メッセージを表示する Public Const OFN_READONLY = &H1 '[読み取り専用]チェックボックスをオンにする Public Const OFN_SHAREAWARE = &H4000 '共有違反エラーを無視する Public Const OFN_SHOWHELP = &H10 'ダイアログ ボックスに [ヘルプ] ボタンを表示する Public Const OFN_EXPLORER = &H80000 'エクスプローラに似たダイアログボックスにする Public Const OFN_NODEREFERENCELINKS = &H100000 'ショートカットを実行しない Public Const OFN_LONGNAMES = &H200000 '長いファイル名を使用する Type OpenFileName2 DefaultExt As String '拡張子を付けなかった時のデフォルト拡張子 DialogTitle As String 'タイトルバーに表示するタイトル名 FileName As String 'ダイアログを閉じた後、選択したファイルのフルパスが入る FilePath As String '選択したファイルが含まれるパスの名前 FileTitle As String '選択したファイルのパスを含まない名前 Filter As String 'フィルター FilterIndex As Long '複数フィルターを設定している時の表示するフィルターのインデックス番号 flags As Long 'ダイアログボックスの作成フラグ InitDir As String '初期フォルダ名 MaxFileSize As Long 'ファイル名の最大サイズを設定 (1〜 32768 既定値256) OKFlg As Integer '1:ファイルを選択した 0:選択をキャンセルした End Type Public Function BufEdit(Buf As String, Optional delimiter) As String '*********************************************************** '機能 : 引数 Bufの文字列中の Nullコードを検索し、Nullコードを '    除いた文字列を返す '引数 : Buf = Nullコードを含む文字列 ' delimiter 指定で vbNullCharを delimiterに変更(追加 1999/06/05) '戻り値: Nullコードを除いた文字列 '*********************************************************** Dim i As Long, j As Long, w As String If IsMissing(delimiter) Then i = InStr(Buf, vbNullChar) If i <> 0 Then BufEdit = Left$(Buf, i - 1) Else BufEdit = Buf End If Else w = Buf i = InStr(w, vbNullChar) Do Until i < 1 Or i = j + 1 j = i Mid$(w, i, 1) = delimiter i = i + 1 i = InStr(i, w, vbNullChar) Loop If i <= Len(w) Then w = Left$(w, i - 1) If Right$(w, 1) <> delimiter Then w = w & delimiter BufEdit = w End If End Function Public Function LsGetOpenFileDialog(hWnd As Long, OpenInfo As OpenFileName2) As OpenFileName2 '*********************************************************** '機能 : 「ファイルを開く」コモンダイアログを呼び出す '引数 :  Fm  = 呼び出し元のフォームのウインドウハンドル '     OpenInfo = 「ファイルを開く」ダイアログの初期設定値 '戻り値: ダイアログを閉じた後の設定値 '*********************************************************** Dim getfile As OPENFILENAME Dim FilterBuf As String Dim StrBuf As String Dim i As Long Dim j As Long Dim cnt As Integer Dim filindex As Integer Dim longret As Long Dim wkOpenInfo As OpenFileName2 '初期値設定 If Left$(OpenInfo.DefaultExt, 1) = "." Then OpenInfo.DefaultExt = Mid$(OpenInfo.DefaultExt, 2) End If If OpenInfo.DialogTitle = vbNullString Then OpenInfo.DialogTitle = "ファイルを開く" End If If OpenInfo.MaxFileSize < 1 Or OpenInfo.MaxFileSize > 32768 Then OpenInfo.MaxFileSize = MAX_PATH End If If OpenInfo.FileTitle = vbNullString Then OpenInfo.FileTitle = String$(OpenInfo.MaxFileSize, 0) End If FilterBuf = OpenInfo.Filter j = 1 cnt = 1 Do While True i = InStr(j, FilterBuf, "|") If i = 0 Then Exit Do End If Mid$(FilterBuf, i, 1) = vbNullChar j = i + 1 cnt = cnt + 1 Loop If OpenInfo.FilterIndex < 1 Or OpenInfo.FilterIndex > cnt Then filindex = 0 Else filindex = OpenInfo.FilterIndex End If StrBuf = String(OpenInfo.MaxFileSize, 0) 'コモンダイアログを呼び出す With getfile .lStructSize = Len(getfile) .hwndOwner = hWnd .hInstance = 0 .lpstrFilter = FilterBuf .nMaxCustrFilter = 0& .nFilterIndex = filindex .lpstrFile = StrBuf .nMaxFile = OpenInfo.MaxFileSize .lpstrFileTitle = OpenInfo.FileTitle .nMaxFileTitle = Len(OpenInfo.FileTitle) + 1 .lpstrInitialDir = OpenInfo.InitDir .lpstrTitle = OpenInfo.DialogTitle .flags = OpenInfo.flags .lpstrDefExt = OpenInfo.DefaultExt End With longret = GetOpenFileName(getfile) wkOpenInfo = OpenInfo With wkOpenInfo .FileTitle = BufEdit(getfile.lpstrFileTitle) If .FileTitle = "" Then .FileName = BufEdit(getfile.lpstrFile, "/") i = InStr(.FileName, "/") If i Then .FileName = Mid$(.FileName, i + 1) Else .FileName = BufEdit(getfile.lpstrFile) End If .FilePath = BufEdit(StrConv(LeftB$(StrConv(getfile.lpstrFile, vbFromUnicode), getfile.nFileOffset), vbUnicode)) If Right$(.FilePath, 1) = "\" Then .FilePath = Left$(.FilePath, Len(.FilePath) - 1) .OKFlg = longret End With LsGetOpenFileDialog = wkOpenInfo End Function '---form------------------------------------------------------------------------------------------------------- Option Compare Database Option Explicit Private Sub cmdMkShortcut_Click() Dim tag As OpenFileName2 Dim text As TextBox 'ダイアログのパラメータ設定 With tag .DefaultExt = "exe" .DialogTitle = "ファイルを選択して下さい。" .FileName = vbNullString .FilePath = vbNullString .FileTitle = vbNullString .Filter = "実行ファイル(*.exe)|*.exe|データベース(*.mdb)|*.mdb|全てのファイル(*.*)|*.*" .FilterIndex = 1 .flags = OFN_HIDEREADONLY .InitDir = "c:\" .MaxFileSize = MAX_PATH .OKFlg = 0 End With 'ダイアログ呼び出し tag = LsGetOpenFileDialog(Me.hWnd, tag) If tag.OKFlg <> 0 Then If MkShortcut(tag.FileName, "") Then MsgBox tag.FileTitle & "のショートカットを作成しました。" End If End If End Sub