Code:
Public Sub m_CreateShortcut(ScFolder As Variant, ScCaption As _ String, TargetPath As String, Optional ScParam As String, _ Optional StartFolder As String, Optional IcoNum As Integer, _ Optional IcoPath As String, Optional WindowMode As Integer) 'If you want to use one of the windows folders for the shortcut 'location, you can pass one of the constants defined in the declarations, e.g., ' CSIDL_PROGRAMS = Programs ' CSIDL_STARTUP = Startup ' CSIDL_RECENT = RecentDocs ' CSIDL_DESKTOP = Desktop 'NOTE: AS WRITTEN THIS CODE MUST BE PLACED 'WITHIN A FORM MODULE 'Example: Puts a shortcut to Notepad on the desktop with ' a .txt document to be opened ' m_CreateShortcut CSIDL_DESKTOP, "MyFile", _ ' "C:\windows\Notepad.exe", "C:\MyFile.txt" Dim Shortcut0 As String 'Full path for the temporary shortcut 'created in the RecentDocs folder. Dim n0 As Integer 'Cusror position in Shortcut0. Dim x0 As String * 1 'Variable while reading Shortcut0. Dim l0 As Long 'Lenth of the Shortcut0 file. Dim Shortcut1 As String 'Full path for the final shortcut. Dim n1 As Integer 'Cusror position in Shortcut1 Dim x1 As String * 1 'Variable while reading Shortcut1. Dim l1 As Long 'Lenth of the Shortcut1 file Dim T As Double Dim p As Long Dim i As Integer Dim x As String Dim y0 As String * 2 'Check for the target folder If IsNumeric(ScFolder) Then ScFolder = p_GetSpecialFolder(CInt(ScFolder)) ElseIf Dir$(ScFolder, vbDirectory) = "" Then MsgBox "Le r‚ø¾rtoire '" & ScFolder & "' est introuvable.", _ vbCritical, "Cr‚­ïion d'un raccrourci" Exit Sub End If 'Create a temporary shortcut with only the 'target in the the RecentDocs. If api_SHAddToRecentDocs(2, TargetPath) > 0 Then 'Full path of the created shortcut Shortcut0 = p_GetSpecialFolder(8) & "\" & _ p_File_Folder(TargetPath) & ".lnk" 'Waiting for the end of the creation. T = Now() Do Until (Dir$(Shortcut0) <> "") If (Now() - T) > 0.00006 Then 'wait 5 seconds If MsgBox("Attendre encore la cr‚­ïion du raccourci ?", _ vbQuestion + vbOKCancel, "Raccourci") <> vbOK Then Exit Sub Else T = Now() End If End If Loop 'Open the temporary shortcut file in read mode. n0 = FreeFile() Open Shortcut0 For Binary Access Read As #n0 'Wait for the file is correctly feed. Do Until LOF(n0) > 0 Loop l0 = LOF(n0) 'Open the shortcut file to create Shortcut1 = ScFolder & "\" & ScCaption & ".lnk" n1 = FreeFile() Open Shortcut1 For Binary Access Write As #n1 'Look for the last byte to get p = (l0 - 4) y0 = "" Do Until (p <= 0) Or (y0 = vbNullChar & vbNullChar) Get #n0, p, y0 p = p - 1 Loop l1 = p + 2 'Copy bytes For p = 1 To l1 Get #n0, p, x0 Select Case p Case 21 'path for icon, startup, parameters i = 3 If StartFolder <> "" Then i = i + 16 End If If ScParam <> "" Then i = i + 32 End If If (IcoPath <> "") Or (IcoNum > 0) Then i = i + 64 End If x1 = Chr$(i) Case 57 'Icon index x1 = Chr$(IcoNum) Case 61 'Window mode x1 = Chr$(WindowMode) Case Else x1 = x0 End Select Put #n1, p, x1 Next p 'Close and delete the temporary shorcut Close #n0 Kill Shortcut0 'Add the Start folder, parameters and icon file x = "" If StartFolder <> "" Then x = x & Chr$(Len(StartFolder)) & vbNullChar & StartFolder End If If ScParam <> "" Then x = x & Chr$(Len(ScParam)) & vbNullChar & ScParam End If If IcoPath = "" Then If IcoNum > 0 Then x = x & Chr$(Len(TargetPath)) & vbNullChar _ & TargetPath End If Else x = x & Chr$(Len(IcoPath)) & vbNullChar & IcoPath End If x = x & String(4, vbNullChar) Put #n1, l1 + 1, x Close #n1 Else MsgBox "Error when creating the shortcut.", _ vbCritical, "Shortcut" End If End Sub Private Function p_GetSpecialFolder(CsIdl As Long) As String 'Returns the full path of the folder corresponding to the 'Windows's id system folder. Dim r As Long Dim pidl As Long Dim sPath As String r = api_SHGetSpecialFolderLocation(Me.hWnd, CsIdl, pidl) If r = 0 Then sPath = Space$(260) r = api_SHGetPathFromIDList(ByVal pidl, ByVal sPath) If r Then p_GetSpecialFolder = Left$(sPath, _ InStr(sPath, Chr$(0)) - 1) End If End If End Function Private Function p_File_Folder(FullPath As String) As String 'Returns the name of the file alone. Dim i As Integer p_File_Folder = FullPath i = Len(FullPath) Do Until i = 0 If Mid$(FullPath, i, 1) = "\" Then p_File_Folder = Mid$(FullPath, i + 1) i = 0 Else i = i - 1 End If Loop End Function