大家好,又见面了,我是你们的朋友全栈君。
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
发布者:全栈程序员-用户IM,转载请注明出处:https://javaforall.cn/151648.html原文链接:https://javaforall.cn
【正版授权,激活自己账号】: Jetbrains全家桶Ide使用,1年售后保障,每天仅需1毛
【官方授权 正版激活】: 官方授权 正版激活 支持Jetbrains家族下所有IDE 使用个人JB账号...