'---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