FreeBasic

Данный код адаптирован с PureBasic. Создает контекстное меню проводника в своей программе, вклинивая туда свой пункт меню.  

Платформа: Windows
Автор оригинала: freak
Адаптация кода под FreeBasic (нужна библиотека window9): Станислав Будинов

#INCLUDE "window9.bi"
#INCLUDE "win/shellapi.bi"
#INCLUDE "crt.bi"

Type CMINVOKECOMMANDINFOEX
    As DWORD   cbSize
    As   DWORD   fMask
    As   HWND    hwnd
    As   LPCSTR  lpVerb
    As   LPCSTR  lpParameters
    As   LPCSTR  lpDirectory
    As   Integer     nShow
    As   DWORD   dwHotKey
    As   HANDLE  hIcon
    As   LPCSTR  lpTitle
    As   LPCWSTR lpVerbW
    As   LPCWSTR lpParametersW
    As   LPCWSTR lpDirectoryW
    As   LPCWSTR lpTitleW
    As   Point   ptInvoke
End Type

Type QCMINFO
    hmenu As HMENU
    indexMenu As UINT
    idCmdFirst As UINT
    idCmdLast As UINT
    pldMap As Any Ptr
End Type

#DEFINE PCIDLIST_ABSOLUTE LPCITEMIDLIST
#DEFINE PCUITEMID_CHILD_ARRAY LPCITEMIDLIST Ptr
#DEFINE GCS_VERBA 0
#DEFINE CMF_NORMAL 0
#DEFINE CMF_CANRENAME 16

#DEFINE DFM_MERGECONTEXTMENU 1
#DEFINE DFM_INVOKECOMMAND 2
#DEFINE DFM_GETDEFSTATICID 14
#DEFINE DFM_CMD_PROPERTIES -5

#DEFINE ExplorerList  1
#DEFINE FirstShellMenuItem 0
#DEFINE LastShellMenuItem 9999


Dim CDefFolderMenu_Create2 As Function(_
pidlFolder As PCIDLIST_ABSOLUTE,_
hwnd As HWND,_
cidl As UINT,_
apidl As PCUITEMID_CHILD_ARRAY Ptr,_
psf As IShellFolder Ptr,_
lpfn As Any Ptr,_
nKeys As UINT,_
ahkeys As HKEY Ptr,_
ppcm As IContextMenu Ptr Ptr) As Integer


Dim Shared As Integer CustomMenuEntry
Dim Memdll As Any Ptr
Dim As HWND HWND
Dim As Integer event
Dim Shared Desktop As IShellFolder Ptr
Dim ShellMenu As IContextMenu Ptr
Dim Parent As IShellFolder Ptr
Dim ParentIDL As LPCITEMIDLIST

' Callback function for the CDefFolderMenu_Create2() call
'
Function Callback(Byref psf As IShellFolder Ptr, hwnd As HWND, pdtobj As IDataObject Ptr, uMsg As Integer, wParam As WPARAM, lParam As LPARAM) As Integer

    Select Case uMsg

        Case DFM_MERGECONTEXTMENU

            ' Here custom entries can be added to the created menu
            '
            Dim qcminfo As QCMINFO Ptr = Cast(QCMINFO Ptr,lParam)
            If qcminfo->idCmdLast > qcminfo->idCmdFirst Then

                If InsertMenu(qcminfo->hmenu, qcminfo->indexMenu, MF_BYPOSITION Or MF_STRING, qcminfo->idCmdFirst, @"--- Custom Menu Entry ---") Then
                    ' Save the ID and tell the caller that one entry was added
                    '
                    CustomMenuEntry = qcminfo->idCmdFirst
                    qcminfo->idCmdFirst += 1
                Endif

            Endif
            Return S_OK

        Case DFM_INVOKECOMMAND

            ' Here the execution of the commands can be overwritten.
            ' return #S_FALSE to get the default behavior
            Return S_FALSE

        Case DFM_GETDEFSTATICID

            ' return #S_FALSE to get the default handling
            Return S_FALSE

        Case Else
            Return E_NOTIMPL

    End Select
End Function

CoInitialize(0)

Memdll=DylibLoad("shell32.dll")'получаем хендл библиотеки
If Memdll=0 Then End
CDefFolderMenu_Create2=DyLibSymbol(Memdll, "CDefFolderMenu_Create2")'получаем указатель на функцию
If CDefFolderMenu_Create2 = 0 Then End

hwnd = OpenWindow("ContextMenu test", 100, 100, 500, 500)
ExplorerListGadget(ExplorerList, 10, 10, 480, 480, "C:\")

Do
    Event = WaitEvent()

    If event=EventRBDown Then
        If EventNumberListView = ExplorerList Then
            ' Get the IDL and IShellFolder for the current directory in the gadget

            If SHGetDesktopFolder(@Desktop) = S_OK Then
                Print "got desktop folder"

                Dim As ZString*256 ParentFolder = GetExplorerListGadgetPath(ExplorerList)

                If Desktop->lpVtbl->ParseDisplayName(Desktop,hwnd, NULL, ParentFolder, NULL, @ParentIDL, NULL) = S_OK Then

                    Print "got parent folder idl"

                    If Desktop->lpVtbl->BindToObject(Desktop,ParentIDL, NULL, @IID_IShellFolder, @Parent) = S_OK Then
                        Print "got parent folder object"


                        ' Get the IDLs for all selected items

                        Dim As HWND LISTVIEW = GetExplorerListGadgetHwnd(ExplorerList)

                        Dim As Integer TotalCount = GetItemCountListView(ExplorerList)

                        Dim As Integer ItemCount = GetSelectedCountListView(ExplorerList)

                        If ItemCount > 0 Then

                            Dim FileIDL(ItemCount-1) As Integer Ptr

                            Dim As Integer ParsedCount



                            For i As Integer = 0 To TotalCount-1
                                Var ItemName = GetTextItemListView(ExplorerList,i,0)
                                If ListView_GetItemState(LISTVIEW,i,LVIS_SELECTED) And ItemName <> ".." Then
                                    If Parent->lpVtbl->ParseDisplayName(Parent,hwnd, NULL, ItemName, NULL, Cast(LPITEMIDLIST Ptr,@FileIDL(ParsedCount)), NULL) = S_OK Then
                                        ParsedCount += 1
                                    Endif
                                Endif
                            Next

                            ' Only go to the menu if parsing all items worked correctly
                            '
                            If ParsedCount = ItemCount Then
                                ?  "got item idl's"

                                ' Free the old menu object
                                If ShellMenu Then
                                    ShellMenu->lpVtbl->Release(ShellMenu)
                                Endif

                                ' Open the registry keys for shell extensions
                                '
                                Dim As Integer KeyCount = 1
                                Dim KeyStrings (KeyCount) As String
                                Dim hKey(KeyCount) As Integer

                                KeyStrings(0) = "*"

                                Dim As Integer KeysOpen
                                
                                For i As Integer= 0 To KeyCount-1
                                    If RegCreateKeyEx(HKEY_CLASSES_ROOT, Cast(LPCTSTR,@KeyStrings(i)), 0, Null, 0, KEY_READ, Null, Cast(PHKEY,@hKey(KeysOpen)), Null) = ERROR_SUCCESS Then
                                        KeysOpen += 1
                                    Endif
                                Next i

                                ' Create the menu object for our items with the above callback
                                '
                                If CDefFolderMenu_Create2(ParentIDL, hwnd, ParsedCount,Cast(PCUITEMID_CHILD_ARRAY Ptr, @FileIDL(0)), Parent, @Callback(), KeysOpen, Cast(HKEY Ptr,@hKey(0)), @ShellMenu) = S_OK Then
                                    ? "got menu"

                                    Dim As HMENU HMENU = CreatePopMenu()

                                    ? "got fb menu"

                                    ' Add the Shell menu to our popup menu
                                    ' You can specify the range of menu item ids to use here (to not conflict with others from your program)
                                    '
                                    If ShellMenu->lpVtbl->QueryContextMenu(ShellMenu,HMENU, 0, FirstShellMenuItem, LastShellMenuItem, CMF_NORMAL Or CMF_CANRENAME) >= 0 Then
                                        ?  "menu items added"

                                        ' Finally display the popup menu
                                        '
                                        DisplayPopupMenu(HMenu,GlobalMouseX,GlobalMouseY)
                                    Endif
                                Endif

                                For i As Integer = 0 To KeysOpen-1
                                    RegCloseKey(Cast(HKEY,hkey(i)))
                                Next

                            Else
                                ?  "error in parsing a selected item"

                            Endif

                            ' Free the item IDLs (as far as they were parsed)
                            '
                            For i  As Integer= 0 To ParsedCount-1
                                CoTaskMemFree(FileIDL(i))
                            Next i

                        Endif

                        Parent->lpVtbl->Release(Parent)
                    Endif

                    CoTaskMemFree(ParentIDL)
                Endif

                Desktop->lpVtbl->Release(Desktop)
            Endif


            ' A menu event from the contextmenu range
        Endif   '
    Elseif Event = EventMenu And ShellMenu<>0 Then

        If EventNumber >= FirstShellMenuItem And EventNumber <= LastShellMenuItem Then

            If EventNumber = CustomMenuEntry Then
                ' Its our custom menu item
                ?  "--- custom menu item selected ---"

            Else
                ' its one of the shell items

                ? "handling event: " & EventNumber

                Dim As ZString*1000 CommandS
                
                If ShellMenu->lpVtbl->GetCommandString(ShellMenu,EventNumber, GCS_VERBA, Null, @CommandS, 1000) = S_OK Then
                    ? "Commmand: " + CommandS

                    ' Some of these commands can be directly passed to ShellExecute_() for example
                Endif

                ' Let the menu object execute this command
                '
                Dim info As CMINVOKECOMMANDINFOEX
                info.cbSize = Sizeof(CMINVOKECOMMANDINFOEX)
                info.hwnd   = hwnd
                info.lpVerb = Cast(LPCSTR,EventNumber)
                info.nShow  = SW_SHOWNORMAL

                Var Err_ = ShellMenu->lpVtbl->InvokeCommand(ShellMenu,Cast(LPCMINVOKECOMMANDINFO,@info))
                If err_ = S_OK Then
                    ?  "command executed"
                Else
                    ? "command could not be executed. error = " & err_
                Endif
            Endif

        Endif
    Endif

Loop Until Event = EventClose


CoUninitialize()

Dylibfree Memdll ' освобождаем DLL