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

最新推荐文章于 2025-08-13 17:19:24 发布

chjk1

最新推荐文章于 2025-08-13 17:19:24 发布

阅读量1k

点赞数

分类专栏：代码库--A(vb.net) 文章标签： menu blog string microsoft object each

代码库--A(vb.net) 专栏收录该内容

14 篇文章

订阅专栏

博客介绍了一段代码，该代码会忽略重复快捷方式，如开始菜单中多个同名的“Readme.txt”快捷方式，仅添加首个。还说明了需向项目添加对象，如模块、窗体、函数等，以及在新代码模块添加相关声明和代码，实现获取开始菜单、桌面、收藏夹快捷方式并添加命令。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

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