“粘贴在窗体(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 (编辑:李大同)
【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容!
|