'ショートカットを作成するサンプルマクロ

'プログラムマネージャにアイコン登録してショートカットを作成し、
'それをデスクトップフォルダへ移動しています。

'Testマクロの「作成するショートカットの設定」の部分を適当に変更してください。

Option Explicit

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" ( _
    ByVal pidl As Long, ByVal lpszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
    ByVal hwnd As Long, ByVal nFolder As Long, ByRef pidl As Any) As Long
Private Declare Function CoTaskMemFree Lib "ole32.dll" (ByRef pv As Any) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" ( _
    ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Private Const CSIDL_PROGRAMS As Long = &h2
Private Const CSIDL_DESKTOPDIRECTORY As Long = &h10
Private Const MAX_PATH As Long = 260

Private Const myTitle As String = "ショートカットの作成"


'SpecialFolderのパスを取得する関数

Function GetSpecialFolderPath(ByVal csidl As Long) As String
    Dim sPath As String
    Dim pidl As Long
    Dim iRet As Long

    GetSpecialFolderPath = ""
    On Error GoTo ErrorHandler
    If SHGetSpecialFolderLocation(0&, csidl, pidl) = 0 Then
        sPath = String$(MAX_PATH + 1, Chr$(0))
        If SHGetPathFromIDList(pidl, sPath) <> 0 Then
            GetSpecialFolderPath = Left$(sPath, InStr(1, sPath, Chr$(0), 0) - 1)
        End If
        iRet = CoTaskMemFree(ByVal pidl)
    End If
    Exit Function
ErrorHandler:
    Exit Function
End Function


'ショートパス名を取得する関数

Function GetShortName(ByVal sPath As String) As String
    Dim sShortPath As String
    Dim iRet As Long

    On Error GoTo ErrorHandler:
    GetShortName = ""
    sShortPath = String$(MAX_PATH + 1, Chr$(0))
    iRet = GetShortPathName(sPath, sShortPath, MAX_PATH)
    If (iRet = 0) Or (iRet > MAX_PATH) Then Exit Function
    GetShortName = Left$(sShortPath, InStr(1, sShortPath, Chr$(0), 0) - 1)
    Exit Function
ErrorHandler:
    Exit Function
End Function


'プログラムマネージャにアイコンを登録する関数

Function CreateProgManItem(ByVal sCmdLine As String, ByVal sName As String, _
        ByVal sIconPath As String, ByVal iIconIndex As Integer) As Boolean
    Dim iChan As Integer
    Dim sParam As String
    Dim vRet As Variant

    On Error GoTo ErrorHandler:

    iChan = Application.DDEInitiate("ProgMan", "ProgMan")

    sParam = """" & sCmdLine & """,""" & sName & """"
    If sIconPath <> "" Then
        sParam = sParam & ",""" & sIconPath & """," _
            & CStr(iIconIndex)
    End If
    Application.DDEExecute iChan, "[AddItem(" & sParam & ")]"
    Application.DDETerminate iChan
    CreateProgManItem = True
    Exit Function
ErrorHandler:
    CreateProgManItem = False
    If iChan <> 0 Then Application.DDETerminate iChan
    Exit Function
End Function

'デスクトップにショートカットを作成する関数
Function CreateShortcut_Desktop(ByVal sCmdLine As String, _
        ByVal sName As String, ByVal sIconPath As String, _
        ByVal iIconIndex As Integer)
    Dim sDeskTopPath As String
    Dim sProgramsPath As String
    Dim sFileName As String

    CreateShortcut_Desktop = 1

    'アイコンファイルのショート名を取得
    If sIconPath <> "" Then
        sIconPath = GetShortName(sIconPath)
        If sIconPath = "" Then
            CreateShortcut_Desktop = 2
            Exit Function
        End If
    End If

    'デスクトップフォルダのパスを取得
    sDeskTopPath = GetSpecialFolderPath(CSIDL_DESKTOPDIRECTORY)
    If Len(sDeskTopPath) = 0 Then
        CreateShortcut_Desktop = 3
        Exit Function
    End If

    'プログラムフォルダのパスを取得（一時的にショートカットを作成するフォルダ）
    sProgramsPath = GetSpecialFolderPath(CSIDL_PROGRAMS)
    If Len(sProgramsPath) = 0 Then
        CreateShortcut_Desktop = 4
        Exit Function
    End If

    If Right$(sDeskTopPath, 1) <> "\" Then sDeskTopPath = sDeskTopPath & "\"
    If Right$(sProgramsPath, 1) <> "\" Then sProgramsPath = sProgramsPath & "\"
    sFileName = sName & ".LNK"

    'ファイルの有無をチェック
    If Dir$(sDeskTopPath & sFileName) <> "" Then
        If MsgBox(sDeskTopPath & sFileName & " は既に存在します。" _
                & Chr$(10) & "上書きしますか?", vbExclamation Or _
                vbOKCancel Or vbDefaultButton2, myTitle) <> vbOK Then
            CreateShortcut_Desktop = -1
            Exit Function
        End If
    End If

    If Dir$(sProgramsPath & sFileName) <> "" Then
        If MsgBox(sProgramsPath & sFileName & " は既に存在します。" _
                & Chr$(10) & "上書きしますか?", vbExclamation Or _
                vbOKCancel Or vbDefaultButton2, myTitle) <> vbOK Then
            CreateShortcut_Desktop = -1
            Exit Function
        End If
    End If

    'プログラムマネージャへのDDEでショートカットを作成
    If Not CreateProgManItem(sCmdLine, sName, sIconPath, iIconIndex) Then
        CreateShortcut_Desktop = 5
        Exit Function
    End If

    'ショートカットを移動
    CreateShortcut_Desktop = 6
    If Dir$(sProgramsPath & sFileName) = "" Then Exit Function
    FileCopy sProgramsPath & sFileName, sDeskTopPath & sFileName
    Kill sProgramsPath & sFileName

    CreateShortcut_Desktop = 0
    Exit Function
ErrorHandler:
    Exit Function
End Function


'デスクトップにショートカットを作成するテストマクロ

Sub Test()
    Dim sCmdLine As String, sName As String, sIconPath As String
    Dim iIconIndex As Integer
    Dim sDeskTopPath As String
    Dim sProgramsPath As String
    Dim sMsg As String
    Dim iRet As Long

    '作成するショートカットの設定
    sCmdLine = "C:\My Documents\Test.xls"
    sName = "Test.xls(テスト)"
    sIconPath = ""
    iIconIndex = 0
    'sIconPath = Application.Path & "\EXCEL.EXE"
    'iIconIndex = 1

    iRet = CreateShortcut_Desktop(sCmdLine, sName, sIconPath, iIconIndex)
    If iRet = 0 Then
        MsgBox "ショートカットを作成しました。", vbInformation, myTitle
    Else
        Select Case iRet
            Case 0
                sMsg = "ショートカットを作成しました。"
            Case -1
                sMsg = "処理はキャンセルされました。"
            Case 1
                sMsg = "エラーが発生しました。"
            Case 2
                sMsg = "アイコンファイル名が不正です。"
            Case 3
                sMsg = "デスクトップフォルダのパスの取得に失敗しました。"
            Case 4
                sMsg = "プログラムフォルダのパスの取得に失敗しました。"
            Case 5
                sMsg = "プログラムマネージャへのアイコン登録でエラーが発生しました。"
            Case 6
                sMsg = "ファイルコピーでエラーが発生しました。"
        End Select
        MsgBox sMsg, vbExclamation, myTitle
    End If
End Sub