contextmenu.pas

Delphi高级开发指南是开发程序的好帮手

unit ContextMenu;

{ Implementation of the context menu shell extension COM object. This
  COM object is responsible for forwarding requests to its partner
  TPopupMenu component. The TPopupMenu component must reside on the
  MenuComponentForm, and is referred to explicitly in this example.
  You can modify this code to make it more flexible and generic in
  the future.

  The TContextMenu component registers itself as a global context menu
  handler. This is accomplished by adding a key to the
  HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers key in the registry.

  jfl
}

interface

uses
  Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Interfaces, Menus,
    ShellAPI, SysUtils;

type
  TContextMenuFactory = class( TComObjectFactory )
  public
    procedure UpdateRegistry( Register: Boolean ); override;
  end;

  TContextMenu = class( TComObject, IShellExtInit, IContextMenu )
  private
    FFileName: String;
    function BuildSubMenu( Menu: HMENU; IndexMenu: Integer;
      var IDCmdFirst: Integer ): HMENU;
  protected
    // Required to disambiguate TComObject.Initialize otherwise a compiler
    // warning will result.
    function IShellExtInit.Initialize = IShellExtInit_Initialize;
  public
    { IShellExtInit members }
    function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
    { IContextMenu }
    function QueryContextMenu(Menu: HMENU;
      indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
    function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;
  end;

var
  // Must be set prior to instantiation of TContextMenu!
  GFileExtensions: TStringList;

const
  MenuCommandStrings: array[ 0..1 ] of String = (
    '&Open with SimpleWord',
    '&Print with SimpleWord' );
  SW_PATH = 'c:\ddhcode\11\simplew3\simpleword.exe';

implementation

{ TContextMenuFactory }
{ Public }

// Custom registration code
procedure TContextMenuFactory.UpdateRegistry( Register: Boolean );
begin
  inherited UpdateRegistry( Register );

  // Register our global context menu handler
  if Register then
  begin
    CreateRegKey( '*\ShellEx\ContextMenuHandlers\SimpleWord', '',
      GUIDToString( Class_ContextMenu ) );
    CreateRegKey( 'CLSID\' + GUIDToString( ClassID ) + '\' +
      ComServer.ServerKey, 'ThreadingModel', 'Apartment' );
  end else
  begin
    DeleteRegKey( '*\ShellEx\ContextMenuHandlers\SimpleWord' );
  end;
end;

{ TContextMenu }
{ Private }

{ Build a context menu using the existing Menu handle. If Menu is nil,
  we create a new menu handle and return it in the function's return
  value. Note that this function does not handle nested (recursive)
  menus. This exercise is left to the reader. }
function TContextMenu.BuildSubMenu( Menu: HMENU; IndexMenu: Integer;
  var IDCmdFirst: Integer ): HMENU;
var
  i: Integer;
  menuItemInfo: TMenuItemInfo;
begin
  if Menu = 0 then
    Result := CreateMenu
  else
    Result := Menu;

  // Build the menu items here
  with menuitemInfo do
  begin
    cbSize          := SizeOf( TMenuItemInfo );
    fMask           := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
                        MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;
    fType           := MFT_STRING;
    fState          := MFS_ENABLED;
    hSubMenu        := 0;
    hbmpChecked     := 0;
    hbmpUnchecked   := 0;
  end;

  for i := 0 to High( MenuCommandStrings ) do
  begin
    menuitemInfo.dwTypeData := PChar(MenuCommandStrings[ i ]);
    menuitemInfo.wID := IDCmdFirst;
    InsertMenuItem( Result, IndexMenu + i, True, menuItemInfo );
    Inc( IDCmdFirst );
  end;
end;

{ IShellExtInit }

function TContextMenu.IShellExtInit_Initialize( pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY ): HResult;
var
  buffer:         String;
  count:          Integer;
  formatEtc:      TFormatEtc;
  medium:         TStgMedium;
begin
  Result := E_FAIL;

  // We must render the data during the Initialize call, since we cannot
  // simply hang onto the IDataObject reference.
  if Assigned( lpdobj ) then
  begin
    // See if the files in the selection list correspond to one of the
    // files that we are intercepting. Note that I do not support multi
    // select. This exercise is left to the reader!
    with formatEtc do
    begin
      cfFormat  := CF_HDROP;
      ptd       := nil;
      dwAspect  := DVASPECT_CONTENT;
      lindex    := -1;
      tymed     := TYMED_HGLOBAL;
    end;

    SetLength( buffer, MAX_PATH );
    OleCheck( lpdobj.GetData( formatEtc, medium ) );
    try
      count := DragQueryFile( medium.hGlobal, -1, @buffer[ 1 ], MAX_PATH );
      if count > 1 then
        Exit;

      // Extract the file extension from the selected file and compare
      // against our list of registered file extension handlers
      DragQueryFile( medium.hGlobal, 0, @buffer[ 1 ], MAX_PATH );
      FFileName := PChar(buffer);
      Result := S_OK;
    finally
      ReleaseStgMedium( medium );
    end;
  end else
    Result := E_INVALIDARG;
end;

{ IContextMenu }

function TContextMenu.QueryContextMenu( Menu: HMENU;
  indexMenu, idCmdFirst, idCmdLast, uFlags: UINT ): HResult;
var
  extension:      String;
  i:              Integer;
  idLastCommand:  Integer;
begin
  Result := E_FAIL;
  idLastCommand := idCmdFirst;

  // Extract the filename extension from the file dropped, and see if we
  // have a handler registered for it
  extension := UpperCase( ExtractFileExt( FFileName ) );

  for i := 0 to GFileExtensions.Count - 1 do
    if extension = GFileExtensions[ i ] then
    begin
      BuildSubMenu( Menu, indexMenu, idLastCommand );
      // Return value is number of items added to context menu
      Result := idLastCommand - idCmdFirst;
      Exit;
    end;
end;

function TContextMenu.InvokeCommand( var lpici:
  TCMInvokeCommandInfo ): HResult;
var
  idCmd: UINT;
begin
  if HIWORD( Integer(lpici.lpVerb) ) <> 0 then
    Result := E_FAIL
  else
  begin
    idCmd := LOWORD( lpici.lpVerb );
    Result := S_OK;
    case idCmd of
      0:
        ShellExecute( GetDesktopWindow, nil, SW_PATH,
          PChar('"' + FFileName + '"'), nil, SW_SHOW );
      1:
        ShellExecute( GetDesktopWindow, nil, SW_PATH,
          PChar('/P "' + FFileName + '"'), nil, SW_SHOW );
      else
        Result := E_FAIL;
    end;
  end;
end;

function TContextMenu.GetCommandString( idCmd, uType: UINT;
  pwReserved: PUINT; pszName: LPSTR; cchMax: UINT ): HResult;
begin
  StrCopy( pszName, 'Test' );
  Result := S_OK;
end;

initialization
  { Note that we create an instance of TContextMenuFactory here rather
    than TComObjectFactory. This is necessary so that we can add some
    custom registry entries by overriding the UpdateRegistry virtual
    function. }
  TContextMenuFactory.Create( ComServer, TContextMenu, Class_ContextMenu,
    'ContextMenu', 'Context Menu Object', ciMultiInstance );

  // Initialize the file extension list
  GFileExtensions := TStringList.Create;
  GFileExtensions.Add( '.PAS' );
  GFileExtensions.Add( '.RTF' );

finalization
  GFileExtensions.Free;
  
end.