'http://www.vbweb.co.uk/show.asp?id=245
'Creating a shortcut In VB Is far more complicated than it should be.
'The easiest way To create a shortcut Is To Add it To the recent documents list,
'And Then move it To where you want it To go.
'First, the code below finds out where the Recent Documents And the Desktop folder
'Is, using the fGetSpecialFolder Function In the module code. This Is so we can copy
'the file from the Recent Documents To the Desktop. If you want To Put it somewhere Else,
'either Set sDesktopPath To an actual path, 'Or use fGetSpecialFolder using the CSIDL_*
'constants.
'Then, the code calls the SHAddToRecentDocs API passing the Text In txtFilePath, And
'pauses For 1 1/2 seconds To ensure that it has been created. If successful, it Then
'works out the Name of the file the API has created, And Then moves it To the desktop.
'Finally, it renames the file To the caption 'specified In txtName.... And that's it!
'Module Code
Public Const CSIDL_DESKTOP = &H0 '// The Desktop - virtual folder
Public Const CSIDL_PROGRAMS = 2 '// Program Files
Public Const CSIDL_CONTROLS = 3 '// Control Panel - virtual folder
Public Const CSIDL_PRINTERS = 4 '// Printers - virtual folder
Public Const CSIDL_DOCUMENTS = 5 '// My Documents
Public Const CSIDL_FAVORITES = 6 '// Favourites
Public Const CSIDL_STARTUP = 7 '// Startup Folder
Public Const CSIDL_RECENT = 8 '// Recent Documents
Public Const CSIDL_SENDTO = 9 '// Send To Folder
Public Const CSIDL_BITBUCKET = 10 '// Recycle Bin - virtual folder
Public Const CSIDL_STARTMENU = 11 '// Start Menu
Public Const CSIDL_DESKTOPFOLDER = 16 '// Desktop folder
Public Const CSIDL_DRIVES = 17 '// My Computer - virtual folder
Public Const CSIDL_NETWORK = 18 '// Network Neighbourhood - virtual folder
Public Const CSIDL_NETHOOD = 19 '// NetHood Folder
Public Const CSIDL_FONTS = 20 '// Fonts folder
Public Const CSIDL_SHELLNEW = 21 '// ShellNew folder
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Public Const FOF_SILENT = &H4
Public Const FOF_NOCONFIRMATION = &H10
Public Const FOF_RENAMEONCOLLISION = &H8
Public Const MAX_PATH As Integer = 260
Public Const SHARD_PATH = &H2&
Public Const SHCNF_IDLIST = &H0
Public Const SHCNE_ALLEVENTS = &H7FFFFFFF
Public 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
Public Type ****EMID
cb As Long
abID As Byte
End Type
Public Type ITEMIDLIST
mkid As ****EMID
End Type
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function SHGetSpecialFolderLocation Lib "Shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Declare Function SHGetSpecialFolderLocationD Lib "Shell32.dll" Alias _
"SHGetSpecialFolderLocation" (ByVal hwndOwner As Long, ByVal nFolder As Long, _
ByRef ppidl As Long) As Long
Declare Function SHAddToRecentDocs Lib "Shell32.dll" (ByVal dwflags As Long, _
ByVal dwdata As String) As Long
Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" _
(lpFileOp As SHFILEOPSTRUCT) As Long
Declare Function SHChangeNotify Lib "Shell32.dll" (ByVal wEventID As Long, _
ByVal uFlags As Long, ByVal dwItem1 As Long, ByVal dwItem2 As Long) As Long
Declare Function SHGetPathFromIDList Lib "Shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Public Function fGetSpecialFolder(CSIDL As Long) As String
Dim sPath As String
Dim IDL As ITEMIDLIST
'
' Retrieve info about system folders such as the "Recent Documents" folder.
' Info is stored in the IDL structure.
'
fGetSpecialFolder = ""
If SHGetSpecialFolderLocation(Form1.hwnd, CSIDL, IDL) = 0 Then
'
' Get the path from the ID list, and return the folder.
'
sPath = Space$(MAX_PATH)
If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then
fGetSpecialFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1) & "\"
End If
End If
End Function
'Form Code
Private Sub cmdCreate_Click()
Dim i As Integer
Dim lResult As Long
Dim lpil As Long
Dim sFilePath As String
Dim sFileName As String
Dim sRecentPath As String
Dim sDesktopPath As String
Dim sFilePathOld As String
Dim sFilePathNew As String
Dim sShortCutName As String
Dim sMsg As String
Dim SHFileOp As SHFILEOPSTRUCT
'
' Add a shortcut to the Windows desktop.
'
' Get the .exe path and display name associated with the
' button that was right clicked (determined by ptbrRightButton).
'
If Trim$(txtFilePath) = "" Then Exit Sub
If Trim$(txtName) = "" Then Exit Sub
On Error GoTo cmdCreateError
Screen.MousePointer = vbHourglass
sFilePath = Trim$(txtFilePath)
sShortCutName = Trim$(txtName) & ".lnk"
'
' Get the paths of the folders to add the shortcuts to.
' The folders are the Recent Files List and the Desktop.
'
sRecentPath = fGetSpecialFolder(CSIDL_RECENT)
'
' NOTE: to create the shortcut in another folder, set sDesktopPath
' to that folder.
'
sDesktopPath = fGetSpecialFolder(CSIDL_DESKTOPDIRECTORY)
sMsg = "Error retrieving folder location."
If sRecentPath <> "" And sDesktopPath <> "" Then
'
' Create a shortcut in the Recent Files list.
'
sMsg = "Error adding shortcut to the Recent File list."
lResult = SHAddToRecentDocs(SHARD_PATH, sFilePath)
Sleep (1500)
If lResult Then
'
' Extract the .exe name from the path.
'
i = 1
sFileName = sFilePath
Do While i
i = InStr(1, sFileName, "\")
If i Then sFileName = Mid$(sFileName, i + 1)
Loop
'
' Move the shortcut from the Recent folder to the Desktop.
' Since the shortcut now resides in the Recent folder,
' modify the file name to include the Recent folder
' path. Also, append ".lnk" to the original filename.
'
sFilePath = sRecentPath & sFileName & ".lnk" & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_MOVE
.pFrom = sFilePath
.pTo = sDesktopPath
.fFlags = FOF_SILENT
End With
sMsg = "Error creating desktop shortcut."
lResult = SHFileOperation(SHFileOp)
Sleep (1500)
If lResult = 0 Then
'
' Rename the link.
'
sFilePathOld = sDesktopPath & sFileName & ".lnk" & vbNullChar & vbNullChar
sFilePathNew = sDesktopPath & sShortCutName & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_RENAME
.pFrom = sFilePathOld
.pTo = sFilePathNew
.fFlags = FOF_SILENT Or FOF_RENAMEONCOLLISION
End With
sMsg = "Error renaming desktop shortcut."
lResult = SHFileOperation(SHFileOp) '123 = can't rename.
sMsg = ""
'
' Refresh the desktop to display the shortcut.
'
Call SHGetSpecialFolderLocationD(Me.hwnd, CSIDL_DESKTOP, lpil)
Call SHChangeNotify(SHCNE_ALLEVENTS, SHCNF_IDLIST, lpil, 0)
End If
End If
End If
Screen.MousePointer = vbDefault
Exit Sub
cmdCreateError:
MsgBox "Error creating desktop shortcut. " & sMsg, vbExclamation, "Create Shortcut"
End Sub
Desktop Shortcut
Reply With Quote
