Snippet Library

Option Explicit

Dim IconCount As Long
Dim DesktopHandle As Long

Public Enum SHOWCMDFLAGS
    SHOWNORMAL = 5
    SHOWMAXIMIZE = 3
    SHOWMINIMIZE = 7
End Enum


Public Function CreateShellLink&(LnkName$, ExeFile$, WorkDir$, ExeArgs$, _
            Iconfile$, IconIdx&, ShowCmd As SHOWCMDFLAGS)
    Dim LnkFile$       ' LinkName & extension
    Dim myPath$        ' Application path
    Dim cShellLink As ShellLinkA   	' An explorer IShellLinkA(Win 95/Win98/WinNT) instance
    Dim cPersistFile As IPersistFile  ' An explorer IPersistFile instance
    Dim hwnd&
    Const lnk$ = ".lnk"      ' Link extension
'----------------------------------------------
    If LnkName = "" Or ExeFile = "" Then
        Exit Function   ' Validate min. input requirements.
    End If

    myPath = App.path
    If Right$(myPath, 1) <> "" Then myPath = myPath & ""

    LnkFile = IIf(InStr(LnkName, ""), LnkName & lnk, myPath & LnkName & lnk)
'-----------------------------------------------
''# Search the Desktop Handle
' hwnd = FindWindow("progman", "program manager")
' hwnd = FindWindowEx(hwnd, 0, "shelldll_defview", vbNullString)
' DesktopHandle = FindWindowEx(hwnd, 0, "syslistview32", vbNullString)
' '# Count Icons
' IconCount = SendMessageByLong(DesktopHandle, LVM_GETITEMCOUNT, 0, 0)
'------------------------------------
    CreateShellLink = False	' Preset Return Unsuccess
    On Error GoTo ErrHandler

    Set cShellLink = New ShellLinkA    ' Create new IShellLink interface
    Set cPersistFile = cShellLink         ' Implement cShellLink's IPersistFile interface

    With cShellLink
        .SetPath ExeFile      ' set command line exe name & path to new ShortCut
        If (WorkDir <> "") Then .SetWorkingDirectory WorkDir  		' Set working directory in shortcut
        If (ExeArgs <> "") Then .SetArguments ExeArgs        	' Add arguments to command line
        If (Iconfile <> "") Then .SetIconLocation Iconfile, IconIdx 	' Set shortcut icon location & index
        .SetShowCmd IIf(ShowCmd = 0, SHOWNORMAL, ShowCmd)    ' Set shortcut's startup mode
    End With

    cShellLink.Resolve 0, SLR_UPDATE
    cPersistFile.Save StrConv(LnkFile, vbUnicode), 0 ' Unicode conversion back... This must be done!
    CreateShellLink = True                           ' Return Success
'-------------------------------------------
ErrHandler:
'---------------------------------------------
    Set cPersistFile = Nothing                       ' Destroy Object
    Set cShellLink = Nothing                         ' Destroy Object
'-----------------------------------------
End Function

none;