Using msagent to scan the start menu

xiaoxiao2021-03-06  54

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 TypeObject NameNew ModuleDoesn't matterNew FormfrmMainFunctionSubMain () - The project will need to start up here.Microsoft Agent ControlAgent Add the following to a new code module: Option Explicit

Public declare function shellexecute lib "shell32.dll" _

Alias ​​"shellexecutea" _

(Byval Hwnd As Long, _

Byval LPOPOPERATION 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 deflult character by not incruding the pat

'**********************************************************

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 dam

x = instribrates (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

'**********************************************************

'Ife it 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