“粘贴在窗体(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,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)
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,_
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,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,1,&H7FFF,CMF_EXPLORE)
Else
hr = icm.QueryContextMenu(hMenu,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,True,mii)
' </optional>
' ===================================================
' Show the item's context menu
idCmd = TrackPopupMenu(hMenu,_
TPM_LEFTALIGN Or _
TPM_RETURNCMD Or _
TPM_RIGHTBUTTON,_
pt.x,pt.y,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,iFocusedItem,ByVal 0&)
For i = 0 To cItems - 1
' objLB.Selected(aiSelitems(i)) = True ' may err...
Call SendMessage(objLB.hWnd,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,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,cb
MoveMemory ByVal pidlNew + cb,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,_
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,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,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 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,.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,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,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 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,lParam)
Call UnSubClass(hWnd)
Exit Function
End Select
WndProc = CallWindowProc(GetProp(hWnd,lParam)
End Function
郭荣华修改
Public Sub 阿雪_ShellContextMenu2(objLB As Control,_
路径 As String,_
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,bail...
' iItem = LBItemFromPt(objLB.hWnd,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,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,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,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,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,refresh the two listBoxes.
If ShowShellContextMenu(objLB.hWnd,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,Shift) Call 阿雪_右键.阿雪_ShellContextMenu2(ListView1,Shift) End If
原文链接：https://www.f2er.com/vb/261138.html