' Desktop—virtual folder
Const CSIDL_DESKTOP = &H0
'
' User's program groups
Const CSIDL_PROGRAMS = &H2
'
' Control Panel.
Const CSIDL_CONTROLS = &H3
'
' Folder containing installed printers.
Const CSIDL_PRINTERS = &H4
'
' Folder that serves as a common repository for documents.
Const CSIDL_PERSONAL = &H5
'
' Folder that serves as a common repository for the user's favorite items.
Const CSIDL_FAVORITES = &H6
'
' Folder that corresponds to the user's Startup program group.
Const CSIDL_STARTUP = &H7
'
' User's most recently used documents.
Const CSIDL_RECENT = &H8
'
' Folder that contains Send To menu items.
Const CSIDL_SENDTO = &H9
'
' Recycle Bin.
Const CSIDL_BITBUCKET = &HA
'
' Start menu items.
Const CSIDL_STARTMENU = &HB
'
' Folder used to physically store file objects on the desktop.
Const CSIDL_DESKTOPDIRECTORY = &H10
'
' My Computer—virtual folder
Const CSIDL_DRIVES = &H11
'
' Network Neighborhood
Const CSIDL_NETWORK = &H12
'
' Network neighborhood.
Const CSIDL_NETHOOD = &H13
'
' Virtual folder containing fonts.
Const CSIDL_FONTS = &H14
'
' Document templates.
Const CSIDL_TEMPLATES = &H15
'
' Folder that contains the programs and folders that
' appear on the Start menu for all users.
Const CSIDL_COMMON_STARTMENU = &H16
'
' Folder that contains the directories for the common
' program groups that appear on the Start menu for all users.
Const CSIDL_COMMON_PROGRAMS = &H17
'
' Folder that contains the programs that appear in the
' Startup folder for all users.
Const CSIDL_COMMON_STARTUP = &H18
'
' Folder that contains files and folders that
' appear on the desktop for all users.
Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19
'
' Folder serving as a common repository for
' application-specificdata.
Const CSIDL_APPDATA = &H1A
'
' Folder that serves as a common repository for printer links.
Const CSIDL_PRINTHOOD = &H1B
Const FO_MOVE = &H1
Const FO_RENAME = &H4
Const FOF_SILENT = &H4
Const FOF_NOCONFIRMATION = &H10
Const FOF_RENAMEONCOLLISION = &H8
Const MAX_PATH As Integer = 260
Const SHARD_PATH = &H2&
Const SHCNF_IDLIST = &H0
Const SHCNE_ALLEVENTS = &H7FFFFFFF
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 Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' Retrieves the ID of a special folder.
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
' Type safe version of SHGetSpecialFolderLocationD.
Private Declare Function SHGetSpecialFolderLocationD Lib "Shell32.dll" _
Alias "SHGetSpecialFolderLocation" (ByVal hwndOwner As Long, _
ByVal nFolder As Long, ByRef ppidl As Long) As Long
' Adds a document to the shell's list of recently used documents or
' clears all documents from the list. The user gains access to the
' list through the Start menu of the Windows taskbar.
Private Declare Function SHAddToRecentDocs Lib "Shell32.dll" _
(ByVal dwflags As Long, ByVal dwdata As String) As Long
' Copies, moves, renames, or deletes a file.
Private Declare Function SHFileOperation Lib "Shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
' Notifies the system of an event that an application has performed.
Private Declare Function SHChangeNotify Lib "Shell32.dll" _
(ByVal wEventID As Long, ByVal uFlags As Long, _
ByVal dwItem1 As Long, ByVal dwItem2 As Long) As Long
' Converts an item identifier list to a file system path.
Private Declare Function SHGetPathFromIDList Lib "Shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Sub CreateShortcut()
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 sStartUpPath 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 start up.
'
On Error GoTo cmdCreateError
Screen.MousePointer = vbHourglass
sFilePath = App.Path & "\gatekeeper.exe"
sShortCutName = "gatekeeper.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)
sStartUpPath = fGetSpecialFolder(CSIDL_STARTUP)
sMsg = "Error retrieving folder location."
If (sRecentPath <> "" And sStartUpPath <> "") Then
'
' Create a shortcut in the Recent Files list. The
' SHARD_PATH flag says that the following parameter
' is a path.
'
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 = sStartUpPath
.fFlags = FOF_SILENT
End With
sMsg = "Error creating start up shortcut."
lResult = SHFileOperation(SHFileOp)
Sleep (1500)
If lResult = 0 Then
'
' Rename the link.
'
sFilePathOld = sStartUpPath & sFileName & ".lnk" & vbNullChar & vbNullChar
sFilePathNew = sStartUpPath & sShortCutName & vbNullChar & vbNullChar
With SHFileOp
.wFunc = FO_RENAME
.pFrom = sFilePathOld
.pTo = sFilePathNew
.fFlags = FOF_SILENT Or FOF_RENAMEONCOLLISION
End With
sMsg = "Error renaming start up shortcut."
lResult = SHFileOperation(SHFileOp) '123 = can't rename.
sMsg = ""
'
' Refresh the desktop to display the shortcut.
'
Call SHGetSpecialFolderLocationD(frmNew.hwnd, CSIDL_STARTUP, lpil)
Call SHChangeNotify(SHCNE_ALLEVENTS, SHCNF_IDLIST, lpil, 0)
End If
End If
End If
Screen.MousePointer = vbDefault
Exit Sub
cmdCreateError:
MsgBox "Error creating start up shortcut. " & sMsg, vbExclamation, "Create Shortcut"
End Sub
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(frmNew.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
Reply With Quote
