Option Explicit
Public Enum SHOWCMDFLAGS
    SHOWNORMAL =  5 
    SHOWMAXIMIZE =  3 
    SHOWMINIMIZE =  7 
End Enum
Public Function fCreateShellLink(sLnkFile As String, _
                                    sExeFile As String, _
                                    sWorkDir As String, _
                                    sExeArgs As String, _
                                    sIconFile As String, _
                                    sDiscrFile As String, _
                                    lIconIdx As Long, _
                                    ShowCmd As SHOWCMDFLAGS) As Long
    '1.Путь к программе
    '2.Путь к файлу с иконкой
    '3.Рабочая директория
    '4.Аргументы передаваемые при запуске
    '5.Описания ярлыка
    '6.Путь к ярлыку
    '7.Индекс извлекаемой иконки из параметра 2
    '8.Как развернуть окно приложения
    Dim cShellLink   As ShellLinkA
    Dim cPersistFile As IPersistFile
    If Len(sLnkFile) =  0  Or Len(sExeFile) =  0  Then Exit Function
    On Error GoTo fCreateShellLinkError
    Set cShellLink = New ShellLinkA
    Set cPersistFile = cShellLink
    With cShellLink
        .SetPath sExeFile
        If Len(sWorkDir) >  0  Then .SetWorkingDirectory sWorkDir
        If Len(sExeArgs) >  0  Then .SetArguments sExeArgs
        If Len(sDiscrFile) >  0  Then .SetDescription sDiscrFile & vbNullChar
        If Len(sIconFile) >  0  Then .SetIconLocation sIconFile, lIconIdx
        .SetShowCmd ShowCmd
    End With
    cShellLink.Resolve  0 , SLR_UPDATE
    cPersistFile.Save StrConv(sLnkFile, vbUnicode),  0 
    fCreateShellLink = True
fCreateShellLinkError:
        Set cPersistFile = Nothing
        Set cShellLink = Nothing
End Function

Private Sub Command1_Click()
    fCreateShellLink param1, param2, param3, param4, param5, param6, param7, SHOWMAXIMIZE
End Sub

Enum ShortCutDest
    DeskTop
    Programs
    StartMenu
    StartUp
End Enum
Public Function CreateLink(dest As ShortCutDest, _
                           ByVal sName As String, _
                           ByVal sPath As String, _
                           Optional HotKey As String = "", _
                           Optional sIcon As String = "", _
                           Optional sWorkingDirectory As String = "", _
                           Optional sSubFolder As String = "", _
                           Optional WinStyle As Integer = vbNormalFocus)
   Dim WshShell As Object
   Dim oShellLink As Object
   Dim sLinkPath As String
   Set WshShell = CreateObject("WScript.Shell")
   Select Case dest
       Case DeskTop
            sLinkPath = WshShell.SpecialFolders("Desktop")
       Case StartMenu
            sLinkPath = WshShell.SpecialFolders("StartMenu")
       Case StartUp
            sLinkPath = WshShell.SpecialFolders("StartUp")
       Case Programs
            sLinkPath = WshShell.SpecialFolders("Programs")
   End Select
   On Error Resume Next
   If sSubFolder <> "" Then
      sLinkPath = sLinkPath & "\" & sSubFolder
      If Dir(sLinkPath) = "" Then MkDir sLinkPath
   End If
   On Error GoTo  0 
   Set oShellLink = WshShell.CreateShortCut(sLinkPath & "\" & sName & ".lnk")
   oShellLink.WindowStyle = WinStyle
   oShellLink.HotKey = sHotKey
   oShellLink.TargetPath = sPath
   oShellLink.IconLocation = sIcon
   oShellLink.Description = sName
   oShellLink.WorkingDirectory = sWorkingDirectory
   oShellLink.Save
   Set oShellLink = Nothing
   Set WshShell = Nothing
End Function

Private Sub Command1_Click()
   CreateLink DeskTop, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
   CreateLink StartMenu, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
   CreateLink StartUp, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows"
   CreateLink Programs, "Calculator", "c:\windows\calc.exe", "CTRL+SHIFT+C", "calc.exe,0", "c:\windows", "WinCalc"
   CreateLink Programs, "Calculator Help", "c:\windows\help\calc.hlp", "", "winhlp32.exe,0", "c:\windows\help", "WinCalc"
   CreateLink Programs, "Visit our web site", "http://vbcity.com", , "shdocvw.dll,0", , "WinCalc", vbMaximizedFocus
End Sub