Using MSAgent to Scan the Start Menu 选择自 wm_ni 的 Blog

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