Note this code will ignore duplicate shortcuts. For example I have 4 or 5 shortcuts in my Start Menu that are named "Readme.txt." Only the first instance of these will get added to the commands all others will produce an error and will be ignored.
Add the following objects to your project:
Object Type
Object Name
New Module
Doesn't matter
New Form
frmMain
Function
SubMain() - The project will need to start up here.
Microsoft Agent Control
Agent
Add the following to a new code module:Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public a As IAgentCtlCharacter
Public Request As Object
Public fso As New FileSystemObject
Public Type ShortCut
Name As String * 80
Path As String * 150
End Type
Public ShortCuts() As ShortCut
Sub Main()
Load frmMain
Dim fldr As Scripting.Folder
Dim wfldr As Scripting.Folder
ReDim ShortCuts(0)
'*************************************************
'Use default Character by not including the path
'*************************************************
frmMain.Agent.Characters.Load "Agent"
Set a = frmMain.Agent.Characters("Agent")
'*************************************************
'Find out the path of the windows directory
'*************************************************
Set wfldr = fso.GetSpecialFolder(WindowsFolder)
'*************************************************
'Get Start Menu Shortcuts
'*************************************************
Set fldr = fso.GetFolder(wfldr.Path & "\Start Menu")
Call AddFolderCommands(fldr, "*.lnk")
'*************************************************
'Get Desktop Shortcuts
'*************************************************
Set fldr = fso.GetFolder(wfldr.Path & "\Start Menu")
Call AddFolderCommands(fldr, "*.lnk")
'*************************************************
'Get Favorites Shortcuts
'*************************************************
Set fldr = fso.GetFolder(wfldr.Path & "\Start Menu")
Call AddFolderCommands(fldr, "*.url")
a.Show
End Sub
Public Sub AddFolderCommands(rfldr As Scripting.Folder, _
lsFileMask As String)
Dim f As Scripting.File
Dim lsName As String
Dim x As Long
Dim fldr As Scripting.Folder
If fso.FolderExists(rfldr.Path) Then
'*************************************************
'Check each file to see if it fits the mask
'*************************************************
For Each f In rfldr.Files
If f.Name Like lsFileMask Then
x = InStrRev(f.Name, ".", , vbTextCompare)
If x <> 0 Then
lsName = Trim$(Left$(f.Name, x - 1))
Else
lsName = Trim$(f.Name)
End If
Call AddCommand(lsName, Trim$(f.Path))
End If
Next
'*************************************************
'Do this for each sub folder as well
'*************************************************
For Each fldr In rfldr.SubFolders
Call AddFolderCommands(fldr, lsFileMask)
Next
End If
End Sub
Public Sub AddCommand(lsName As String, lsPath As String)
On Error GoTo EndCmd
'*************************************************
'If there is duplicate items ignore all but the
'first instance.
'*************************************************
a.Commands.Add lsName, lsName, lsName, True, True
ReDim Preserve ShortCuts(UBound(ShortCuts) + 1)
ShortCuts(UBound(ShortCuts)).Name = lsName
ShortCuts(UBound(ShortCuts)).Path = lsPath
EndCmd:
End Sub
