CreateShortcutDesk

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

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