.NET开发

本类阅读TOP10

·NHibernate快速指南(翻译)
·vs.net 2005中文版下载地址收藏
·【小技巧】一个判断session是否过期的小技巧
·VB/ASP 调用 SQL Server 的存储过程
·?dos下编译.net程序找不到csc.exe文件
·通过Web Services上传和下载文件
·学习笔记(补)《.NET框架程序设计(修订版)》--目录
·VB.NET实现DirectDraw9 (2) 动画
·VB.NET实现DirectDraw9 (1) 托管的DDraw
·建站框架规范书之——文件命名

分类导航
VC语言Delphi
VB语言ASP
PerlJava
Script数据库
其他语言游戏开发
文件格式网站制作
软件工程.NET开发
Using MSAgent to Scan the Start Menu

作者:未知 来源:月光软件站 加入时间:2005-2-28 月光软件站

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
 


相关文章

相关软件