Windows外壳扩展编程之添加右键菜单

    file://如果操作系统为Windows NT的话
      if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      with TRegistry.Create do
      try
         RootKey := HKEY_LOCAL_MACHINE;
         OpenKey(''''SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions'''', True);
         OpenKey(''''Approved'''', True);
         WriteString(ClassID, ''''Context Menu Shell Extension'''');
      finally
         Free;
      end;
   end
   else begin
      DeleteRegKey(''''*\shellex\ContextMenuHandlers\FileOpreation'''');
      DeleteRegKey(''''*\shellex\ContextMenuHandlers'''');
//      DeleteRegKey(''''*\shellex'''');
      inherited UpdateRegistry(Register);
   end;
end;

initialization
 TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
   '''''''', ''''Context Menu Shell Extension'''', ciMultiInstance,tmApartment);

end.

    将该单位文件保存为unit2.pas，文件同contextmenu.dpr位于同一个目录下。
    打开Delphi，选菜单中的 file | open project 打开contextmenu.dpr文件，然后选 Project | build contextmenu菜单项编译连接程序，如果编译成功的话，会建立一个contextmenu.dll的动态连接库文件，这个文件就是服务器动态连接库。

    下面来建立文件操作程序。打开VB，建立一个新的工程文件，在Form1中加入一个ListBox控件和三个CommandButton控件，将ListBox的MultiSelect属性设置为2。然后在Form1的代码窗口中加入以下代码：
Option Explicit

Private Type BrowseInfo
     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type
Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long       ''''对文件的操作指令
    pFrom As String     ''''源文件或路径
    pTo As String       ''''目的文件或路径
    fFlags As Integer   ''''操作标志
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As String
End Type

Const FO_COPY = &H2
Const FO_DELETE = &H3
Const FO_MOVE = &H1
Const FO_RENAME = &H4
Const FOF_ALLOWUNDO = &H40
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260

Private Declare Function ShellAbout Lib "shell32.dll" Alias _
        "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As _
        String, ByVal szOtherStuff As String, ByVal hIcon As Long) _
        As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias _
        "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 _
        As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi _
        As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHFileOperation Lib "shell32" _
        (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function GetWindowsDirectory _
        Lib "kernel32" Alias "GetWindowsDirectoryA" _
        (ByVal lpBuffer As String, ByVal nSize As _
        Long) As Long

Dim DirString As String
Dim sFile As String

Sub UpdateList()
    ''''UpdateList函数检查列表框中的文件是否存在，如果不存在，就将其
    ''''从文件列表中删除
    Dim bEndList As Boolean
    Dim i As Integer
   
    bEndList = True
    i = 0
    While bEndList
        ''''检查文件是否存在，如果不存在就删除
        If Dir$(List1.List(i)) = "" Then
            List1.RemoveItem (i)
        Else    ''''如果文件存在就转移到下一个列表项
            i = i + 1
            If i > List1.ListCount - 1 Then
                bEndList = False
            End If
        End If
    Wend
    Command1.Enabled = False
    Command2.Enabled = False
    Command3.Enabled = False
End Sub

Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

    ''''初试化udtBI结构
     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With
   
    ''''弹出文件夹查看窗口
     lpIDList = SHBrowseForFolder(udtBI)
    
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If

     BrowseForFolder = sPath
End Function

Private Sub Command1_Click()    ''''执行文件拷贝操作
    Dim sPath As String
    Dim tCopy As SHFILEOPSTRUCT
    Dim i As Integer
   
    ''''选择拷贝到的文件夹
    sPath = BrowseForFolder(Form1.hwnd, "选择拷贝到的文件夹")
    If sPath <> "" Then
        With tCopy
            .hwnd = Form1.hwnd
            .lpszProgressTitle = "正在拷贝"
            .pTo = sPath
            .fFlags = FOF_ALLOWUNDO
            .wFunc = FO_COPY
        End With
        For i = 0 To List1.ListCount - 1
            If List1.Selected(i) Then   ''''如果文件被选中则拷贝文件
                tCopy.pFrom = List1.List(i)
                SHFileOperation tCopy
            End If
        Next i
        UpdateList
    End If
    Kill sFile
End Sub

Private Sub Command2_Click()    ''''执行文件移动操作
    Dim sPath As String
    Dim tCopy As SHFILEOPSTRUCT
    Dim i As Integer
   
    ''''选择移动到的文件夹
    sPath = BrowseForFolder(Form1.hwnd, "选择转移到的文件夹")
    If sPath <> "" Then
        With tCopy
            .hwnd = Form1.hwnd
            .lpszProgressTitle = "正在移动"
            .pTo = sPath
            .fFlags = FOF_ALLOWUNDO
    &n

上一页  [1] [2] [3]  下一页

Copyright ＠ 2007-2012 敏韬网(敏而好学，文韬武略--MinTao.Net)（学习笔记） Inc All Rights Reserved.
闵涛 E_mail:admin@mintao.net(欢迎提供学习资源)

鄂公网安备 42011102001154号

站长：MinTao ICP备案号：鄂ICP备11006601号-18