[VB 源码] 调用资源管理器右键菜单/弹出文件右键系统菜单-2

 

“粘贴在窗体(from)中的代码：”我的浏览器.frm

Private Sub ShellContextMenu(objLB As Control, _
                                                 X As Single, _
                                                 Y As Single, _
                                                 Shift As Integer)
 
  Dim pt As POINTAPI               ' screen location of the cursor
  Dim iItem As Integer                ' listbox index of the selected item (item under the cursor)
  Dim cItems As Integer             ' count of selected items
  Dim i As Integer                       ' counter
  Dim asPaths() As String           ' array of selected items' paths (zero based)
  Dim apidlFQs() As Long           ' array of selected items' fully qualified pidls (zero based)
  Dim isfParent As IShellFolder   ' selected items' parent shell folder
  Dim apidlRels() As Long           ' array of selected items' relative pidls (zero based)
 
  ' ==================================================
  ' Get the listbox item under the cursor
 
  ' Convert the listbox's client twip coords to screen pixel coords.
  pt.X = X \ Screen.TwipsPerPixelX
  pt.Y = Y \ Screen.TwipsPerPixelY
  Call ClientToScreen(objLB.hWnd, pt)

  ' Get the zero-based index of the item under the cursor.
  ' If none exists, bail...
  iItem = LBItemFromPt(objLB.hWnd, pt.X, pt.Y, False)
  If (iItem = LB_ERR) Then Exit Sub
   
  ' ==================================================
  ' Set listbox focus and selection
 
'  objLB.SetFocus阿雪取消
 
  ' If neither the Control and/or Shift key are pressed...
  If (Shift And (vbCtrlMask Or vbShiftMask)) = False Then
   
    ' If Dir1 has the focus...
    If (TypeOf objLB Is DirListBox) Then
      ' Select the item under the cursor. The DirListBox
      ' doesn't have a Selected property, so we'll get forceful...
      Call SendMessage(Dir1.hWnd, LB_SETCURSEL, iItem, 0)
   
    Else
      ' File1 has the focus, duplicate Explorer listview selection functionality.
     
      ' If the right clicked item isn't selected....
      If (File1.Selected(iItem) = False) Then
        ' Deselect all of the items and select the right clicked item.
        Call SendMessage(File1.hWnd, LB_SETSEL, CFalse, ByVal -1)
        File1.Selected(iItem) = True
      Else
      ' The right clciked item is selected, give it the selection rectangle
      ' (or caret, does not deselect any other currently selected items).
      ' File1.Selected doesn't set the caret if the item is already selected.
        Call SendMessage(File1.hWnd, LB_SETCARETINDEX, iItem, ByVal 0&)
      End If
   
    End If   '  (TypeOf objLB Is DirListBox)
  End If   ' (Shift And (vbCtrlMask Or vbShiftMask)) = False
 
  ' ==================================================
  ' Load the path(s) of the selected listbox item(s) into the array.
 
  If (TypeOf objLB Is DirListBox) Then
    ' Only one directory can be selected in the DirLB
    cItems = 1
    ReDim asPaths(0)
    asPaths(0) = GetDirLBItemPath(Dir1, iItem)
    List1.AddItem "GetFileLBItemPath(File1, iItem) " & asPaths(0)
  Else
    ' Put the focused (and selected) files's relative pidl in the
    ' first element of the array. This will be the file whose context
    ' menu will be shown if multiple files are selected.
    cItems = 1
    ReDim asPaths(0)
    asPaths(0) = GetFileLBItemPath(File1, iItem)
    List1.AddItem "GetDirLBItemPath(Dir1, iItem) " & asPaths(0)
    ' Fill the array with the relative pidls of the rest of any selected
    ' files(s), making sure that we don't add the focused file again.
    For i = 0 To File1.ListCount - 1
      If (File1.Selected(i)) And (i <> iItem) Then
        cItems = cItems + 1
        ReDim Preserve asPaths(cItems - 1)
        asPaths(cItems - 1) = GetFileLBItemPath(File1, i)
        List1.AddItem "asPaths(cItems - 1) = GetFileLBItemPath(File1, i) " & asPaths(cItems - 1)
      End If
    Next
 
  End If   ' (TypeOf objLB Is DirListBox)
 
  ' ==================================================
  ' Finally, get the IShellFolder of the selected directory, load the relative
  ' pidl(s) of the selected items into the array, and show the menu.
  ' This part won't be elaborated upon, as it is extensively involved.
  ' For more info on IShellFolder, pidls and the shell's context menu, see:
  ' http://msdn.microsoft.com/developer/sdk/inetsdk/help/itt/Shell/NameSpace.htm
 
  If Len(asPaths(0)) Then
   
    ' Get a copy of each selected item's fully qualified pidl from it's path.
    For i = 0 To cItems - 1
      ReDim Preserve apidlFQs(i)
      apidlFQs(i) = GetPIDLFromPath(hWnd, asPaths(i))
      List1.AddItem "apidlFQs(i) = GetPIDLFromPath(hWnd, asPaths(i))" & apidlFQs(i)
    Next
   
    If apidlFQs(0) Then
   
      ' Get the selected item's parent IShellFolder.
      Set isfParent = GetParentIShellFolder(apidlFQs(0))
      List1.AddItem "isfParent = GetParentIShellFolder(apidlFQs(0))"
      If (isfParent Is Nothing) = False Then
       
        ' Get a copy of each selected item's relative pidl (the last item ID)
        ' from each respective item's fully qualified pidl.
        For i = 0 To cItems - 1
          ReDim Preserve apidlRels(i)
          apidlRels(i) = GetItemID(apidlFQs(i), GIID_LAST)
          List1.AddItem " apidlRels(i) = GetItemID(apidlFQs(i), GIID_LAST)" & apidlRels(i)
        Next
       
        If apidlRels(0) Then
          ' Subclass the Form so we catch the menu's ownerdraw messages.
          Call SubClass(hWnd, AddressOf WndProc)
          ' Show the shell context menu for the selected items. If a
          ' menu command was executed, refresh the two listboxes.
          If ShowShellContextMenu(hWnd, isfParent, cItems, apidlRels(0), pt, True) Then
            Dir1.Refresh
            Call RefreshListBox(File1)
          End If
          ' Finally, unsubclass the form.
          Call UnSubClass(hWnd)
        End If   ' apidlRels(0)
       
        ' Free each item's relative pidl.
        For i = 0 To cItems - 1
          Call MemAllocator.Free(ByVal apidlRels(i))
        Next
       
      End If   ' (isfParent Is Nothing) = False

      ' Free each item's fully qualified pidl.
      For i = 0 To cItems - 1
        Call MemAllocator.Free(ByVal apidlFQs(i))
      Next
     
    End If   ' apidlFQs(0)
  End If   ' Len(asPaths(0))
 
End Sub

Private Function GetFileLBItemPath(objFLB As FileListBox, iItem As Integer) As String
  Dim sPath As String
 
  sPath = objFLB.Path
  If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
  GetFileLBItemPath = sPath & objFLB.List(iItem)

End Function

' Returns the DirListBox Path from the specified listbox item index.

'   - the currently expanded directory (lowest in hierarchy) is ListIndex -1
'   - it's 1st parent directory's ListIndex is -2, if any (the parent indices get smaller)
'   - it's 1st child subdirectory's ListIndex is 0, if any (the child indices get larger)
'   - ListCount is the number of child subdirectories under the currently expanded directory.
'   - List(x) returns the full path of item whose index is x
'   - there is never more than one expanded directory on any directory hierachical level

' It's a little extra work getting the path of the selected DirListBox item...

Private Function GetDirLBItemPath(objDLB As DirListBox, iItem As Integer) As String
  Dim nItems As Integer
 
  ' Get the count of items in the DirLB
  nItems = SendMessage(objDLB.hWnd, LB_GETCOUNT, 0, 0)
  If (nItems > -1) Then   ' LB_ERR
       
    ' Subtract the actual number of LB items from the sum of:
    '   the DirLB's ListCount and
    '   the currently selected directory's real LB index value
    ' (nItems is a value of 1 greater than the last item's real LB index value)
    GetDirLBItemPath = objDLB.List((objDLB.ListCount + iItem) - nItems)

'Debug.Print "iItem: " & iItem & ", LiistIndex: " & (objDLB.ListCount + iItem) - nItems

  End If

End Function

Private Sub RefreshListBox(objLB As Control)
  Dim iFocusedItem As Integer
  Dim i As Integer
  Dim cItems As Integer
  Dim aiSelitems() As Integer
 
  ' Cache the focused item, if any.
  iFocusedItem = objLB.ListIndex
 
  ' Cache any selected items
  For i = 0 To objLB.ListCount - 1
    If objLB.Selected(i) Then
      cItems = cItems + 1
      ReDim Preserve aiSelitems(cItems - 1)
      aiSelitems(cItems - 1) = i
    End If
  Next
  Private Sub Dir1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If (Button = vbRightButton) Then
        Call ShellContextMenu(Dir1, X, Y, Shift)
    End If
End Sub

Attribute VB_Name = "mMenuDefs"
Option Explicit

' Brought to you by Brad Martinez
'   http://members.aol.com/btmtz/vb
'   http://www.mvps.org/ccrp
'
' Code was written in and formatted for 8pt MS San Serif
'
' Note that "IShellFolder Extended Type Library v1.2" (ISHF_Ex.tlb)
' included with this project, must be present and correctly registered
' on your system, and referenced by this project, to allow use of the
' IShellFolder, IContextMenu and IMalloc interfaces.

' ====================================================

' C language BOOLEAN constants
Public Const CFalse = False
Public Const CTrue = 1

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
                      (pDest As Any, pSource As Any, ByVal dwLength As Long)

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                            (ByVal hWnd As Long, _
                            ByVal wMsg As Long, _
                            ByVal wParam As Long, _
                            lParam As Any) As Long

Public Const LB_ERR = -1
Public Const LB_SETSEL = &H185           ' multi-selection lbs only
Public Const LB_SETCURSEL = &H186   ' single selection lbs only
Public Const LB_GETCOUNT = &H18B
Public Const LB_SETCARETINDEX = &H19E  ' multi-selection lbs only

' Returns the listbox index if the specified point is over a list item,
' or - 1 otherwise. The ptX & ptY params want to be screen coords.
' Requires a tad more coding to make bAutoScroll functional but
' works nicely when dragging...
Declare Function LBItemFromPt Lib "comctl32.dll" _
                            (ByVal hLB As Long, _
                             ByVal ptX As Long, _
                             ByVal ptY As Long, _
                             ByVal bAutoScroll As Long) As Long

Public Type POINTAPI   ' pt
  x As Long
  y As Long
End Type

' Converts the specified window's client coordinates to screen coordinates
Declare Function ClientToScreen Lib "user32" _
                              (ByVal hWnd As Long, _
                              lpPoint As POINTAPI) As Long

' ShowWindow commands
Public Enum SW_cmds
  SW_HIDE = 0
  SW_NORMAL = 1
  SW_SHOWNORMAL = 1
  SW_SHOWMINIMIZED = 2
  SW_MAXIMIZE = 3
  SW_SHOWMAXIMIZED = 3
  SW_SHOWNOACTIVATE = 4
  SW_SHOW = 5
  SW_MINIMIZE = 6
  SW_SHOWMINNOACTIVE = 7
  SW_SHOWNA = 8
  SW_RESTORE = 9
  SW_MAX = 10
  SW_SHOWDEFAULT = 10
End Enum

' ====================================================
' menu defs

Declare Function CreatePopupMenu Lib "user32" () As Long
Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Declare Function TrackPopupMenu Lib "user32" _
                              (ByVal hMenu As Long, _
                              ByVal wFlags As TPM_wFlags, _
                              ByVal x As Long, _
                              ByVal y As Long, _
                              ByVal nReserved As Long, _
                              ByVal hWnd As Long, _
                              lprc As Any) As Long   ' lprc As RECT

Public Enum TPM_wFlags
  TPM_LEFTBUTTON = &H0
  TPM_RIGHTBUTTON = &H2
  TPM_LEFTALIGN = &H0
  TPM_CENTERALIGN = &H4
  TPM_RIGHTALIGN = &H8
  TPM_TOPALIGN = &H0
  TPM_VCENTERALIGN = &H10
  TPM_BOTTOMALIGN = &H20

  TPM_HORIZONTAL = &H0         ' Horz alignment matters more
  TPM_VERTICAL = &H40            ' Vert alignment matters more
  TPM_NONOTIFY = &H80           ' Don't send any notification msgs
  TPM_RETURNCMD = &H100
End Enum

Public Type MENUITEMINFO
  cbSize As Long
  fMask As MII_Mask
  fType As MF_Type              ' MIIM_TYPE
  fState As MF_State             ' MIIM_STATE
  wID As Long                       ' MIIM_ID
  hSubMenu As Long            ' MIIM_SUBMENU
  hbmpChecked As Long      ' MIIM_CHECKMARKS
  hbmpUnchecked As Long  ' MIIM_CHECKMARKS
  dwItemData As Long          ' MIIM_DATA
  dwTypeData As String        ' MIIM_TYPE
  cch As Long                       ' MIIM_TYPE
End Type

Public Enum MII_Mask
  MIIM_STATE = &H1
  MIIM_ID = &H2
  MIIM_SUBMENU = &H4
  MIIM_CHECKMARKS = &H8
  MIIM_TYPE = &H10
  MIIM_DATA = &H20
End Enum

' win40  -- A lot of MF_* flags have been renamed as MFT_* and MFS_* flags
Public Enum MenuFlags
  MF_INSERT = &H0
  MF_ENABLED = &H0
  MF_UNCHECKED = &H0
  MF_BYCOMMAND = &H0
  MF_STRING = &H0
  MF_UNHILITE = &H0
  MF_GRAYED = &H1
  MF_DISABLED = &H2
  MF_BITMAP = &H4
  MF_CHECKED = &H8
  MF_POPUP = &H10
  MF_MENUBARBREAK = &H20
  MF_MENUBREAK = &H40
  MF_HILITE = &H80
  MF_CHANGE = &H80
  MF_END = &H80                    ' Obsolete -- only used by old RES files
  MF_APPEND = &H100
  MF_OWNERDRAW = &H100
  MF_DELETE = &H200
  MF_USECHECKBITMAPS = &H200
  MF_BYPOSITION = &H400
  MF_SEPARATOR = &H800
  MF_REMOVE = &H1000
  MF_DEFAULT = &H1000
  MF_SYSMENU = &H2000
  MF_HELP = &H4000
  MF_RIGHTJUSTIFY = &H4000
  MF_MOUSESELECT = &H8000&
End Enum

Public Enum MF_Type
  MFT_STRING = MF_STRING
  MFT_BITMAP = MF_BITMAP
  MFT_MENUBARBREAK = MF_MENUBARBREAK
  MFT_MENUBREAK = MF_MENUBREAK
  MFT_OWNERDRAW = MF_OWNERDRAW
  MFT_RADIOCHECK = &H200
  MFT_SEPARATOR = MF_SEPARATOR
  MFT_RIGHTORDER = &H2000
  MFT_RIGHTJUSTIFY = MF_RIGHTJUSTIFY
End Enum

Public Enum MF_State
  MFS_GRAYED = &H3
  MFS_DISABLED = MFS_GRAYED
  MFS_CHECKED = MF_CHECKED
  MFS_HILITE = MF_HILITE
  MFS_ENABLED = MF_ENABLED
  MFS_UNCHECKED = MF_UNCHECKED
  MFS_UNHILITE = MF_UNHILITE
  MFS_DEFAULT = MF_DEFAULT
End Enum

Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" _
                              (ByVal hMenu As Long, _
                              ByVal uItem As Long, _
                              ByVal fByPosition As Boolean, _
                              lpmii As MENUITEMINFO) As Boolean

Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" _
                              (ByVal hMenu As Long, _
                              ByVal uItem As Long, _
                              ByVal fByPosition As Boolean, _
                              lpmii As MENUITEMINFO) As Boolean
'

' Displays the specified items' shell context menu.
'
'    hwndOwner  - window handle that owns context menu and any err msgboxes
'    isfParent       - pointer to the items' parent shell folder
'    cPidls            - count of pidls at, and after, pidlRel
'    pidlRel          - the first item's pidl, relative to isfParent
'    pt                  - location of the context menu, in screen coords
'    fPrompt         - flag specifying whether to prompt before executing any selected
'                           context menu command
'
' Returns True if a context menu command was selected, False otherwise.

Public Function ShowShellContextMenu(hwndOwner As Long, _
                                                                isfParent As IShellFolder, _
                                                                cPidls As Integer, _
                                                                pidlRel As Long, _
                                                                pt As POINTAPI, _
                                                                fPrompt As Boolean) As Boolean
  Dim IID_IContextMenu As GUID
  Dim IID_IContextMenu2 As GUID
  Dim icm As IContextMenu
  Dim hr As Long   ' HRESULT
  Dim hMenu As Long
  Dim idCmd As Long
  Dim cmi As CMINVOKECOMMANDINFO
  ' <optional>
  Dim mii As MENUITEMINFO
  Const idOurCmd = 100
  Const sOurCmd = "&Our menu command :-)"
  ' </optional>

  ' Fill the IContextMenu interface ID, {000214E4-000-000-C000-000000046}
  With IID_IContextMenu
    .Data1 = &H214E4
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With
   
  ' Get a refernce to the item's IContextMenu interface.
  hr = isfParent.GetUIObjectOf(hwndOwner, cPidls, pidlRel, IID_IContextMenu, 0, icm)
  If hr >= NOERROR Then
   
    ' Fill the IContextMenu2 interface ID, {000214F4-000-000-C000-000000046}
    ' and get the folder's IContextMenu2. Is needed so the "Send To" and "Open
    ' With" submenus get filled from the HandleMenuMsg call in WndProc.
    With IID_IContextMenu2
      .Data1 = &H214F4
      .Data4(0) = &HC0
      .Data4(7) = &H46
    End With
    Call icm.QueryInterface(IID_IContextMenu2, ICtxMenu2)
   
    ' Create a new popup menu...
    hMenu = CreatePopupMenu()
    If hMenu Then

      ' Add the item's shell commands to the popup menu.
      If (ICtxMenu2 Is Nothing) = False Then
        hr = ICtxMenu2.QueryContextMenu(hMenu, 0, 1, &H7FFF, CMF_EXPLORE)
      Else
        hr = icm.QueryContextMenu(hMenu, 0, 1, &H7FFF, CMF_EXPLORE)
      End If
      If hr >= NOERROR Then
       
        ' ===================================================
        ' <optional>
        ' Now for fun, we'll add a menu item to the top of the context menu

        mii.cbSize = Len(mii)
        mii.fMask = MIIM_ID Or MIIM_TYPE
        mii.wID = idOurCmd
        mii.fType = MFT_STRING
        mii.dwTypeData = sOurCmd
        mii.cch = Len(sOurCmd)
        Call InsertMenuItem(hMenu, 0, True, mii)
         
        ' </optional>
        ' ===================================================
       
        ' Show the item's context menu
        idCmd = TrackPopupMenu(hMenu, _
                                                    TPM_LEFTALIGN Or _
                                                    TPM_RETURNCMD Or _
                                                    TPM_RIGHTBUTTON, _
                                                    pt.x, pt.y, 0, hwndOwner, 0)
       
        ' If a menu command is selected...
        If idCmd Then
         
          ' ===================================================
          ' <optional>
          ' If prompting before executing the command...
         
          If fPrompt Then
            If MsgBox("The """ & GetMenuCmdStr(hMenu, (idCmd)) & """ context menu command was chosen." & vbCrLf & _
                            "Execute the command?", vbQuestion Or vbYesNo) = vbNo Then
              idCmd = 0
            End If
          End If   ' fPrompt
         
          ' If the selected menu command is our command, we're responsible
          ' for excuting it. The InvokeCommand below, which will also attempt
          ' to execute it if selected, will fail since there is no corresponding verb
          ' for our command in any registered file type (i.e."Open", etc.).
          If (idCmd = idOurCmd) Then MsgBox "We just executed " & sOurCmd
         
          ' </optional>
          ' ===================================================
       
          ' If still executing the command...
          If idCmd Then
           
            ' Fill the struct with the selected command's information.
            With cmi
              .cbSize = Len(cmi)
              .hWnd = hwndOwner
              .lpVerb = idCmd - 1 ' MAKEINTRESOURCE(idCmd-1);
              .nShow = SW_SHOWNORMAL
            End With
 
            ' Invoke the shell's context menu command. The call itself does
            ' not err if the pidlRel item is invalid, but depending on the selected
            ' command, Explorer *may* raise an err. We don't need the return
            ' val, which should always be NOERROR anyway...
            If (ICtxMenu2 Is Nothing) = False Then
              Call ICtxMenu2.InvokeCommand(cmi)
            Else
              Call icm.InvokeCommand(cmi)
            End If
         
          End If   ' idCmd
        End If   ' idCmd
      End If   ' hr >= NOERROR (QueryContextMenu)

      Call DestroyMenu(hMenu)
   
    End If   ' hMenu
  End If   ' hr >= NOERROR (GetUIObjectOf)

  ' Release the folder's IContextMenu2 from the global variable.
  Set ICtxMenu2 = Nothing
 
  ' Return True if a menu command was selected
  ' (letting us know to react accordingly...)
  ShowShellContextMenu = CBool(idCmd)

End Function

' Returns the string of the specified menu command ID in the specified menu.

Public Function GetMenuCmdStr(hMenu As Long, idCmd As Integer) As String
  Dim mii As MENUITEMINFO
 
  ' Initialize the struct..
  With mii
    .cbSize = Len(mii)
    .fMask = MIIM_TYPE
    .fType = MFT_STRING
    .dwTypeData = String$(256, 0)
    .cch = 256
  End With
 
  ' Returns TRUE on success
  If GetMenuItemInfo(hMenu, idCmd, False, mii) Then
    GetMenuCmdStr = Left$(mii.dwTypeData, mii.cch)
  End If

End Function

  ' Refresh the listbox, sets ListIndex = 0, and removes all selction.
  objLB.Refresh

  ' Restore focus and selection to the cached items.
'  objLB.ListIndex = iFocusedItem   ' this errs... (?)
  Call SendMessage(objLB.hWnd, LB_SETCARETINDEX, iFocusedItem, ByVal 0&)
  For i = 0 To cItems - 1
'    objLB.Selected(aiSelitems(i)) = True   ' may err...
    Call SendMessage(objLB.hWnd, LB_SETSEL, CTrue, ByVal aiSelitems(i))
  Next
 
End Sub

 

Attribute VB_Name = "mShellDefs"
Option Explicit

' Brought to you by Brad Martinez
'   http://members.aol.com/btmtz/vb
'   http://www.mvps.org/ccrp
'
' Code was written in and formatted for 8pt MS San Serif
'
' Note that "IShellFolder Extended Type Library v1.1" (ISHF_Ex.tlb)
' included with this project, must be present and correctly registered
' on your system, and referenced by this project, to allow use of the
' IShellFolder, IContextMenu and IMalloc interfaces.

' ====================================================

' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0

' Retrieves the IShellFolder interface for the desktop folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long

' Retrieves a pointer to the shell's IMalloc interface.
' Returns NOERROR if successful or or E_FAIL otherwise.
Declare Function SHGetMalloc Lib "shell32" (ppMalloc As IMalloc) As Long

' GetItemID item ID retrieval constants
Public Const GIID_FIRST = 1
Public Const GIID_LAST = -1
'
' ====================================================
' item ID (pidl) structs, just for reference
'
' item identifier (relative pidl), allocated by the shell
'Type SHITEMID
'  cb As Integer        ' size of struct, including cb itself
'  abID(0) As Byte    ' variable length item identifier
'End Type
'
' fully qualified pidl
'Type ITEMIDLIST
'  mkid As SHITEMID  ' list of item identifers, packed into SHITEMID.abID
'End Type
'

' Returns a reference to the IMalloc interface.

Public Function MemAllocator() As IMalloc
  Static im As IMalloc
  ' SHGetMalloc should just get called once as the 'im'
  ' variable stays in scope while the project is running...
  If im Is Nothing Then Call SHGetMalloc(im)
  Set MemAllocator = im
End Function

' ====== Begin pidl procs ===============================

' Determines if the specified pidl is the desktop folder's pidl.
' Returns True if the pidl is the desktop's pidl, returns False otherwise.

' The desktop pidl is only a single item ID whose value is 0 (the 2 byte
' zero-terminator, i.e. SHITEMID.abID is empty). Direct descendents of
' the desktop (My Computer, Network Neighborhood) are absolute pidls
' (relative to the desktop) also with a single item ID, but contain values
' (SHITEMID.abID > 0). Drive folders have 2 item IDs, children of drive
' folders have 3 item IDs, etc. All other single item ID pidls are relative to
' the shell folder in which they reside (just like a relative path).

Public Function IsDesktopPIDL(pidl As Long) As Boolean
  ' The GetItemIDSize() call will also return 0 if pidl = 0
  If pidl Then IsDesktopPIDL = (GetItemIDSize(pidl) = 0)
End Function

' Returns the size in bytes of the first item ID in a pidl.
' Returns 0 if the pidl is the desktop's pidl or is the last
' item ID in the pidl (the zero terminator), or is invalid.

Public Function GetItemIDSize(ByVal pidl As Long) As Integer
  ' If we try to access memory at address 0 (NULL), then it's bye-bye...
  If pidl Then MoveMemory GetItemIDSize, ByVal pidl, 2
End Function

' Returns the count of item IDs in a pidl.

Public Function GetItemIDCount(ByVal pidl As Long) As Integer
  Dim nItems As Integer
  ' If the size of an item ID is 0, then it's the zero
  ' value terminating item ID at the end of the pidl.
  Do While GetItemIDSize(pidl)
    pidl = GetNextItemID(pidl)
    nItems = nItems + 1
  Loop
  GetItemIDCount = nItems
End Function

' Returns a pointer to the next item ID in a pidl.
' Returns 0 if the next item ID is the pidl's zero value terminating 2 bytes.

Public Function GetNextItemID(ByVal pidl As Long) As Long
  Dim cb As Integer   ' SHITEMID.cb, 2 bytes
  cb = GetItemIDSize(pidl)
  ' Make sure it's not the zero value terminator.
  If cb Then GetNextItemID = pidl + cb
End Function

' If successful, returns the size in bytes of the memory occcupied by a pidl,
' including it's 2 byte zero terminator. Returns 0 otherwise.

Public Function GetPIDLSize(ByVal pidl As Long) As Integer
  Dim cb As Integer
  ' Error handle in case we get a bad pidl and overflow cb.
  ' (most item IDs are roughly 20 bytes in size, and since an item ID represents
  ' a folder, a pidl can never exceed 260 folders, or 5200 bytes).
  On Error GoTo Out
 
  If pidl Then
    Do While pidl
      cb = cb + GetItemIDSize(pidl)
      pidl = GetNextItemID(pidl)
    Loop
    ' Add 2 bytes for the zero terminating item ID
    GetPIDLSize = cb + 2
  End If
 
Out:
End Function

' Copies and returns the specified item ID from a complex pidl
'   pidl -    pointer to an item ID list from which to copy
'   nItem - 1-based position in the pidl of the item ID to copy

' If successful, returns a new item ID (single-element pidl)
' from the specified element positon. Returns 0 on failure.
' If nItem exceeds the number of item IDs in the pidl,
' the last item ID is returned.
' (calling proc is responsible for freeing the new pidl)

Public Function GetItemID(ByVal pidl As Long, ByVal nItem As Integer) As Long
  Dim nCount As Integer
  Dim i As Integer
  Dim cb As Integer
  Dim pidlNew As Long
 
  nCount = GetItemIDCount(pidl)
  If (nItem > nCount) Or (nItem = GIID_LAST) Then nItem = nCount
 
  ' GetNextItemID returns the 2nd item ID
  For i = 1 To nItem - 1: pidl = GetNextItemID(pidl): Next
   
  ' Get the size of the specified item identifier.
  ' If cb = 0 (the zero terminator), the we'll return a desktop pidl, proceed
  cb = GetItemIDSize(pidl)
 
  ' Allocate a new item identifier list.
  pidlNew = MemAllocator.Alloc(cb + 2)
  If pidlNew Then
   
    ' Copy the specified item identifier.
    ' and append the zero terminator.
    MoveMemory ByVal pidlNew, ByVal pidl, cb
    MoveMemory ByVal pidlNew + cb, 0, 2
   
    GetItemID = pidlNew
  End If
 
End Function

' Returns an absolute pidl (relative to the desktop) from a valid file system
' path only (i.e. not from a display name).

'   hwndOwner - handle of window that will own any displayed msg boxes
'   sPath           - fully qualified path whose pidl is to be returned

' If successful, the path's pidl is returned, otherwise 0 is returned.
' (calling proc is responsible for freeing the pidl)

Public Function GetPIDLFromPath(hwndOwner As Long, _
                                                      sPath As String) As Long
  Dim isfDesktop As IShellFolder
  Dim pchEaten As Long
  Dim pidl As Long

  If SHGetDesktopFolder(isfDesktop) = NOERROR Then
    If isfDesktop.ParseDisplayName(hwndOwner, 0, _
                                                        StrConv(sPath, vbUnicode), _
                                                        pchEaten, _
                                                        pidl, 0) = NOERROR Then
      GetPIDLFromPath = pidl
    End If
  End If
End Function
'
' ====== End pidl procs ===============================
'

' Returns a reference to the parent IShellFolder of the last
' item ID in the specified fully qualified pidl.

' If pidlFQ is zero, or a relative (single item) pidl, then the
' desktop's IShellFolder is returned.
' If an unexpected error occurs, the object value Nothing is returned.

Public Function GetParentIShellFolder(ByVal pidlFQ As Long) As IShellFolder
  Dim nCount As Integer
  Dim i As Integer
  Dim isf As IShellFolder
  Dim pidlRel As Long
  Dim IID_IShellFolder As GUID
  On Error GoTo Out

  nCount = GetItemIDCount(pidlFQ)
  ' If pidlFQ is 0 and is not the desktop's pidl...
  If (nCount = 0) And (IsDesktopPIDL(pidlFQ) = False) Then Error 1
 
  ' Get the desktop's IShellfolder first.
  If SHGetDesktopFolder(isf) = NOERROR Then
   
    ' Fill the IShellFolder interface ID, {000214E6-000-000-C000-000000046}
    With IID_IShellFolder
      .Data1 = &H214E6
      .Data4(0) = &HC0
      .Data4(7) = &H46
    End With
   
    ' Walk through the pidl and bind all the way to it's *2nd to last* item ID.
    For i = 1 To nCount - 1
     
      ' Get the next item ID in the pidl (child of the current IShellFolder)
      pidlRel = GetItemID(pidlFQ, i)
     
      ' Bind to the item current ID's folder and get it's IShellFolder
      If isf.BindToObject(pidlRel, 0, IID_IShellFolder, isf) <> NOERROR Then Error 1
     
      ' Free the current item ID and zero it
      MemAllocator.Free ByVal pidlRel
      pidlRel = 0
   
    Next
 
  End If   ' SHGetDesktopFolder(isf) = NOERROR
 
Out:
  If pidlRel Then MemAllocator.Free ByVal pidlRel
 
  ' Return a reference to the IShellFolder
  Set GetParentIShellFolder = isf
 
End Function

Attribute VB_Name = "mWndProc"
Option Explicit

' Brad Martinez http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

Private Const WM_DRAWITEM = &H2B
Private Const WM_MEASUREITEM = &H2C
Private Const WM_INITMENUPOPUP = &H117

Public ICtxMenu2 As IContextMenu2

' =========================

Private Const WM_DESTROY = &H2

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Public Enum GWL_nIndex
  GWL_WNDPROC = (-4)
'  GWL_HWNDPARENT = (-8)
  GWL_ID = (-12)
  GWL_STYLE = (-16)
  GWL_EXSTYLE = (-20)
'  GWL_USERDATA = (-21)
End Enum

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As GWL_nIndex) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As GWL_nIndex, ByVal dwNewLong As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const OLDWNDPROC = "OldWndProc"
Private Const OBJECTPTR = "ObjectPtr"

' Set to non-zero to prevent the IDE from freezing when subclassed and
' stepping through code. Requires the "Debug Object for AddressOf
' Subclassing" (Dbgwproc.dll), last found at:
' http://msdn.microsoft.com/vbasic/downloads/download.asp?ID=024
#Const DEBUGWINDOWPROC = 0

#If DEBUGWINDOWPROC Then
' maintains a WindowProcHook object reference for each subclassed window.
' The subclassed window's handle is used as the collection item's key string.
Private m_colWPHooks As New Collection
#End If
'

Public Function SubClass(hWnd As Long, _
                                         lpfnNew As Long, _
                                         Optional objNotify As Object = Nothing) As Boolean
  Dim lpfnOld As Long
  Dim fSuccess As Boolean
  On Error GoTo Out
 
  If GetProp(hWnd, OLDWNDPROC) Then
    SubClass = True
    Exit Function
  End If
 
#If (DEBUGWINDOWPROC = 0) Then
    lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, lpfnNew)

#Else
    Dim objWPHook As WindowProcHook
   
    Set objWPHook = CreateWindowProcHook
    m_colWPHooks.Add objWPHook, CStr(hWnd)
   
    With objWPHook
      Call .SetMainProc(lpfnNew)
      lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, .ProcAddress)
      Call .SetDebugProc(lpfnOld)
    End With

#End If
 
  If lpfnOld Then
    fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
    If (objNotify Is Nothing) = False Then
      fSuccess = fSuccess And SetProp(hWnd, OBJECTPTR, ObjPtr(objNotify))
    End If
  End If
 
Out:
  If fSuccess Then
    SubClass = True
 
  Else
    If lpfnOld Then Call SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
    MsgBox "Error subclassing window &H" & Hex(hWnd) & vbCrLf & vbCrLf & _
                  "Err# " & Err.Number & ": " & Err.Description, vbExclamation
  End If
 
End Function

Public Function UnSubClass(hWnd As Long) As Boolean
  Dim lpfnOld As Long
 
  lpfnOld = GetProp(hWnd, OLDWNDPROC)
  If lpfnOld Then
   
    If SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld) Then
      Call RemoveProp(hWnd, OLDWNDPROC)
      Call RemoveProp(hWnd, OBJECTPTR)

#If DEBUGWINDOWPROC Then
      ' remove the WindowProcHook reference from the collection
      On Error Resume Next
      m_colWPHooks.Remove CStr(hWnd)
#End If
     
      UnSubClass = True
   
    End If   ' SetWindowLong
  End If   ' lpfnOld

End Function

' Returns the specified object reference stored in the subclassed
' window's OBJECTPTR window property.
' The object reference is valid for only as long as the calling proc holds it.

Public Function GetObj(hWnd As Long) As Object
  Dim Obj As Object
  Dim pObj As Long
  pObj = GetProp(hWnd, OBJECTPTR)
  If pObj Then
    MoveMemory Obj, pObj, 4
    Set GetObj = Obj
    MoveMemory Obj, 0&, 4
  End If
End Function

Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
  Select Case uMsg
   
    ' ======================================================
    ' Handle owner-draw context menu messages (for the Send To submenu)
   
    Case WM_INITMENUPOPUP, WM_DRAWITEM, WM_MEASUREITEM
      If (ICtxMenu2 Is Nothing) = False Then
        Call ICtxMenu2.HandleMenuMsg(uMsg, wParam, lParam)
      End If
   
    ' ======================================================
    ' Unsubclass the window.
   
    Case WM_DESTROY
      ' OLDWNDPROC will be gone after UnSubClass is called!
      Call CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
      Call UnSubClass(hWnd)
      Exit Function
     
  End Select
 
  WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
 
End Function

 

郭荣华修改

Public Sub 阿雪_ShellContextMenu2(objLB As Control, _
                                 路径 As String, _
                                                 X As Single, _
                                                 Y As Single, _
                                                 Shift As Integer)
 
  Dim pt As POINTAPI               ' screen location of the cursor
'  Dim iItem As Integer                ' listbox index of the selected item (item under the cursor)
  Dim cItems As Integer             ' count of selected items
  Dim i As Integer                       ' counter
  Dim asPaths() As String           ' array of selected items' paths (zero based)
  Dim apidlFQs() As Long           ' array of selected items' fully qualified pidls (zero based)
  Dim isfParent As IShellFolder   ' selected items' parent shell folder
  Dim apidlRels() As Long           ' array of selected items' relative pidls (zero based)
 
  ' ==================================================
  ' Get the listbox item under the cursor
 
  ' Convert the listbox's client twip coords to screen pixel coords.
  pt.X = X \ Screen.TwipsPerPixelX
  pt.Y = Y \ Screen.TwipsPerPixelY
  Call ClientToScreen(objLB.hWnd, pt)

  ' Get the zero-based index of the item under the cursor.
  ' If none exists, bail...
'  iItem = LBItemFromPt(objLB.hWnd, pt.X, pt.Y, False)
'  If (iItem = LB_ERR) Then Exit Sub
   
  ' ==================================================
  ' Set listbox focus and selection
 
'  objLB.SetFocus阿雪取消
 
  ' If neither the Control and/or Shift key are pressed...
'  If (Shift And (vbCtrlMask Or vbShiftMask)) = False Then
'
'    ' If Dir1 has the focus...
'    If (TypeOf objLB Is DirListBox) Then
'      ' Select the item under the cursor. The DirListBox
'      ' doesn't have a Selected property, so we'll get forceful...
'      Call SendMessage(Dir1.hWnd, LB_SETCURSEL, iItem, 0)
'
'    Else
'      ' File1 has the focus, duplicate Explorer listview selection functionality.
'
'      ' If the right clicked item isn't selected....
'      If (File1.Selected(iItem) = False) Then
'        ' Deselect all of the items and select the right clicked item.
'        Call SendMessage(File1.hWnd, LB_SETSEL, CFalse, ByVal -1)
'        File1.Selected(iItem) = True
'      Else
'      ' The right clciked item is selected, give it the selection rectangle
'      ' (or caret, does not deselect any other currently selected items).
'      ' File1.Selected doesn't set the caret if the item is already selected.
'        Call SendMessage(File1.hWnd, LB_SETCARETINDEX, iItem, ByVal 0&)
'      End If
'
'    End If   '  (TypeOf objLB Is DirListBox)
'  End If   ' (Shift And (vbCtrlMask Or vbShiftMask)) = False
 
 
'''''''''''''''''''''''''''''''''''''''''''''''''''
'========================================================================================================
  ' Load the path(s) of the selected listbox item(s) into the array.
 
'  If (TypeOf objLB Is DirListBox) Then
'    ' Only one directory can be selected in the DirLB
'    cItems = 1
'    ReDim asPaths(0)
'    asPaths(0) = GetDirLBItemPath(Dir1, iItem)
'    List1.AddItem "GetFileLBItemPath(File1, iItem) " & asPaths(0)
'  Else
'    ' Put the focused (and selected) files's relative pidl in the
'    ' first element of the array. This will be the file whose context
'    ' menu will be shown if multiple files are selected.
'    cItems = 1
'    ReDim asPaths(0)
'    asPaths(0) = GetFileLBItemPath(File1, iItem)
'    List1.AddItem "GetDirLBItemPath(Dir1, iItem) " & asPaths(0)
'    ' Fill the array with the relative pidls of the rest of any selected
'    ' files(s), making sure that we don't add the focused file again.
'    For i = 0 To File1.ListCount - 1
'      If (File1.Selected(i)) And (i <> iItem) Then
'        cItems = cItems + 1
'        ReDim Preserve asPaths(cItems - 1)
'        asPaths(cItems - 1) = GetFileLBItemPath(File1, i)
'        List1.AddItem "asPaths(cItems - 1) = GetFileLBItemPath(File1, i) " & asPaths(cItems - 1)
'      End If
'    Next
'
'  End If   ' (TypeOf objLB Is DirListBox)
'''''''''''''''''''''''''''''''''''''''''''''''''''
'========================================================================================================
  cItems = 1
  ReDim asPaths(0)
  asPaths(0) = 路径
  ' ==================================================
  ' Finally, get the IShellFolder of the selected directory, load the relative
  ' pidl(s) of the selected items into the array, and show the menu.
  ' This part won't be elaborated upon, as it is extensively involved.
  ' For more info on IShellFolder, pidls and the shell's context menu, see:
  ' http://msdn.microsoft.com/developer/sdk/inetsdk/help/itt/Shell/NameSpace.htm
 
  If Len(asPaths(0)) Then
   
    ' Get a copy of each selected item's fully qualified pidl from it's path.
    For i = 0 To cItems - 1
      ReDim Preserve apidlFQs(i)
      apidlFQs(i) = GetPIDLFromPath(objLB.hWnd, asPaths(i))
'      List1.AddItem "apidlFQs(i) = GetPIDLFromPath(hWnd, asPaths(i))" & apidlFQs(i)
    Next
   
    If apidlFQs(0) Then
   
      ' Get the selected item's parent IShellFolder.
      Set isfParent = GetParentIShellFolder(apidlFQs(0))
'      List1.AddItem "isfParent = GetParentIShellFolder(apidlFQs(0))"
      If (isfParent Is Nothing) = False Then
       
        ' Get a copy of each selected item's relative pidl (the last item ID)
        ' from each respective item's fully qualified pidl.
        For i = 0 To cItems - 1
          ReDim Preserve apidlRels(i)
          apidlRels(i) = GetItemID(apidlFQs(i), GIID_LAST)
'          List1.AddItem " apidlRels(i) = GetItemID(apidlFQs(i), GIID_LAST)" & apidlRels(i)
        Next
       
        If apidlRels(0) Then
          ' Subclass the Form so we catch the menu's ownerdraw messages.
          Call SubClass(objLB.hWnd, AddressOf WndProc)
          ' Show the shell context menu for the selected items. If a
          ' menu command was executed, refresh the two listboxes.
          If ShowShellContextMenu(objLB.hWnd, isfParent, cItems, apidlRels(0), pt, True) Then
'            Dir1.Refresh
'            Call RefreshListBox(File1)
          End If
          ' Finally, unsubclass the form.
          Call UnSubClass(objLB.hWnd)
        End If   ' apidlRels(0)
       
        ' Free each item's relative pidl.
        For i = 0 To cItems - 1
          Call MemAllocator.Free(ByVal apidlRels(i))
        Next
       
      End If   ' (isfParent Is Nothing) = False

      ' Free each item's fully qualified pidl.
      For i = 0 To cItems - 1
        Call MemAllocator.Free(ByVal apidlFQs(i))
      Next
     
    End If   ' apidlFQs(0)
  End If   ' Len(asPaths(0))
 
End Sub

 

     If (Button = vbRightButton) Then
'        Call 阿雪_ShellContextMenu(ListView1, dname, X, Y, Shift)
         Call 阿雪_右键.阿雪_ShellContextMenu2(ListView1, dname, X, Y, Shift)
    End If