Private Const ERROR_SUCCESS As Long = 0
Private Const CSIDL_PROGRAMS As Long = &H2
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10

Private Const FO_COPY As Long = &H2
Private Const FOF_SILENT As Long = &H4
Private Const FOF_NOCONFIRMATION As Long = &H10

Private Type SHFILEOPSTRUCT
  hWnd      As Long
  wFunc      As Long
  pFrom      As String
  pTo        As String
  fFlags     As Integer
  fAborted   As Boolean
  hNameMaps  As Long
  sProgress  As String
End Type

Private Declare Function SHFileOperation Lib "shell32" _
   Alias "SHFileOperationA" _
  (lpFileOp As SHFILEOPSTRUCT) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32" _
   Alias "SHGetPathFromIDListA" _
  (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   pidl As Long) As Long

Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long



Private Sub Form_Load()

   Dim cnt As Long
   
   For cnt = 0 To 5
   
      If cnt > 0 Then
         Load Text1(cnt)
         Load Label1(cnt)
      End If
      
      With Text1(cnt)
         .Text = ""
         .Move 2300, 300 + (cnt * 300), 6000, 285
         .Visible = True
         .Text = cnt
      End With
      
      With Label1(cnt)
         .Move 200, 310 + (cnt * 310), 100, 285
         .AutoSize = True
         .Visible = True

         Select Case cnt
            Case 0: .Caption = "User's Desktop path:"
            Case 1: .Caption = "User's Program Files path:"
            Case 2: .Caption = "Path to application link:"
            Case 3: .Caption = "Source link (path/file):"
            Case 4: .Caption = "Destination (path/file):"
            Case 5: .Caption = "Desktop link created:"
         End Select
         
      End With
   Next
   
End Sub


Private Sub Command1_Click()

   Dim sPathToDesktop As String
   Dim sPathToStartMenuPrograms As String
   Dim sPathToStartMenuProgramAppFolder As String
   Dim sNameOfShortcut As String
   Dim sSourceFileToCopy As String
   Dim sShortcutOnDesktop As String
   
  'path to the current user's Desktop folder
   sPathToDesktop = GetSpecialFolder(Me.hWnd, CSIDL_DESKTOPDIRECTORY)

  'path to the current user's Programs folder
   sPathToStartMenuPrograms = GetSpecialFolder(Me.hWnd, CSIDL_PROGRAMS)
   
  'path to application link folder under Programs
   sPathToStartMenuProgramAppFolder = QualifyPath(QualifyPath(sPathToStartMenuPrograms) & "MyApp")
  
  'name of shortcut in that folder (must specify the extension!)
   sNameOfShortcut = "MyApp.lnk"
   
  'path and name of file under programs folder
   sSourceFileToCopy = sPathToStartMenuProgramAppFolder & sNameOfShortcut
   
  'path and name of file expected on desktop
   sShortcutOnDesktop = QualifyPath(sPathToDesktop) & sNameOfShortcut
   
  'show the results
   Text1(0).Text = sPathToDesktop
   Text1(1).Text = sPathToStartMenuPrograms
   Text1(2).Text = sPathToStartMenuProgramAppFolder
   Text1(3).Text = sSourceFileToCopy
   Text1(4).Text = sShortcutOnDesktop

  'create the desktop link
   Call CreateDesktopLink(sSourceFileToCopy, sPathToDesktop)

  'confirm creation using Dir() returning the file name created
   Text1(5).Text = Dir(sShortcutOnDesktop)
   
End Sub


Private Sub CreateDesktopLink(sSource As String, sDestination As String)

   Dim SHFileOp As SHFILEOPSTRUCT
  
  'terminate passed strings with a null
   sSource = sSource & Chr$(0)
   sDestination = sDestination & Chr$(0)
  
  'set up the options
   With SHFileOp
     .wFunc = FO_COPY
     .pFrom = sSource
     .pTo = sDestination
     .fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
   End With
   
  'and perform the copy
   Call SHFileOperation(SHFileOp)
  
End Sub


Private Function GetSpecialFolder(hWnd As Long, CSIDL As Long) As String

  Dim pidl As Long
  Dim sPath As String
     
 'fill the pidl with the specified folder item
   If SHGetSpecialFolderLocation(hWnd, CSIDL, pidl) = ERROR_SUCCESS Then
     
     'initialize & get the path
      sPath = Space$(260)

      If SHGetPathFromIDList(ByVal pidl, ByVal sPath) Then
      
        'return folder
         GetSpecialFolder = TrimNull(sPath)
         
      End If
          
   End If
    
   Call CoTaskMemFree(pidl)
    
End Function


Private Function QualifyPath(sPath As String) As String
 
   If Len(sPath) > 0 Then
 
      If Right$(sPath, 1) <> "\" Then
         QualifyPath = sPath & "\"
      Else
         QualifyPath = sPath
      End If
   Else
      QualifyPath = ""
   End If
   
End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function