.NET开发

本类阅读TOP10

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:

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