unit DragDropContext;

// -----------------------------------------------------------------------------
// Project:         Drag and Drop Component Suite.
// Module:          DragDropContext
// Description:     Implements Context Menu Handler Shell Extensions.
// Version:         4.0
// Date:            18-MAY-2001
// Target:          Win32, Delphi 5-6
// Authors:         Anders Melander, anders@melander.dk, http://www.melander.dk
// Copyright        © 1997-2001 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
interface

uses
  DragDrop,
  DragDropComObj,
  Menus,
  ShlObj,
  ActiveX,
  Windows,
  Classes;

{$include DragDrop.inc}

type
////////////////////////////////////////////////////////////////////////////////
//
//		TDropContextMenu
//
////////////////////////////////////////////////////////////////////////////////
// Partially based on Borland's ShellExt demo.
////////////////////////////////////////////////////////////////////////////////
// A typical shell context menu handler session goes like this:
// 1. User selects one or more files and right clicks on them.
//    The files must of a file type which has a context menu handler registered.
// 2. The shell loads the context menu handler module.
// 3. The shell instantiates the registered context menu handler object as an
//    in-process COM server.
// 4. The IShellExtInit.Initialize method is called with a data object which
//    contains the dragged data.
// 5. The IContextMenu.QueryContextMenu method is called to populate the popup
//    menu.
//    TDropContextMenu uses the PopupMenu property to populate the shell context
//    menu.
// 6. If the user chooses one of the context menu menu items we have supplied,
//    the IContextMenu.InvokeCommand method is called.
//    TDropContextMenu locates the corresponding TMenuItem and fires the menu
//    items OnClick event.
// 7. The shell unloads the context menu handler module (usually after a few
//    seconds).
////////////////////////////////////////////////////////////////////////////////
  TDropContextMenu = class(TInterfacedComponent, IShellExtInit, IContextMenu)
  private
    FContextMenu: TPopupMenu;
    FMenuOffset: integer;
    FDataObject: IDataObject;
    FOnPopup: TNotifyEvent;
    FFiles: TStrings;
    procedure SetContextMenu(const Value: TPopupMenu);
  protected
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    { IShellExtInit }
     function 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;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property DataObject: IDataObject read FDataObject;
    property Files: TStrings read FFiles;
  published
    property ContextMenu: TPopupMenu read FContextMenu write SetContextMenu;
    property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//		TDropContextMenuFactory
//
////////////////////////////////////////////////////////////////////////////////
// COM Class factory for TDropContextMenu.
////////////////////////////////////////////////////////////////////////////////
  TDropContextMenuFactory = class(TShellExtFactory)
  protected
    function HandlerRegSubKey: string; virtual;
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//		Component registration
//
////////////////////////////////////////////////////////////////////////////////
procedure Register;


////////////////////////////////////////////////////////////////////////////////
//
//		Misc.
//
////////////////////////////////////////////////////////////////////////////////


////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
//			IMPLEMENTATION
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
implementation

uses
  DragDropFile,
  DragDropPIDL,
  Registry,
  ComObj,
  SysUtils;

////////////////////////////////////////////////////////////////////////////////
//
//		Component registration
//
////////////////////////////////////////////////////////////////////////////////

procedure Register;
begin
  RegisterComponents(DragDropComponentPalettePage, [TDropContextMenu]);
end;


////////////////////////////////////////////////////////////////////////////////
//
//		Utilities
//
////////////////////////////////////////////////////////////////////////////////


////////////////////////////////////////////////////////////////////////////////
//
//		TDropContextMenu
//
////////////////////////////////////////////////////////////////////////////////
constructor TDropContextMenu.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FFiles := TStringList.Create;
end;

destructor TDropContextMenu.Destroy;
begin
  FFiles.Free;
  inherited Destroy;
end;

function TDropContextMenu.GetCommandString(idCmd, uType: UINT;
  pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
var
  ItemIndex: integer;
begin
  ItemIndex := integer(idCmd);
  // Make sure we aren't being passed an invalid argument number
  if (ItemIndex >= 0) and (ItemIndex < FContextMenu.Items.Count) then
  begin
    if (uType = GCS_HELPTEXT) then
      // return help string for menu item.
      StrLCopy(pszName, PChar(FContextMenu.Items[ItemIndex].Hint), cchMax);
    Result := NOERROR;
  end else
    Result := E_INVALIDARG;
end;

function TDropContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
  ItemIndex: integer;
begin
  Result := E_FAIL;

  // Make sure we are not being called by an application
  if (FContextMenu = nil) or (HiWord(Integer(lpici.lpVerb)) <> 0) then
    Exit;

  ItemIndex := LoWord(lpici.lpVerb);
  // Make sure we aren't being passed an invalid argument number
  if (ItemIndex < 0) or (ItemIndex >= FContextMenu.Items.Count) then
  begin
    Result := E_INVALIDARG;
    Exit;
  end;

  // Execute the menu item specified by lpici.lpVerb.
  try
    try
      FContextMenu.Items[ItemIndex].Click;
      Result := NOERROR;
    except
      on E: Exception do
      begin
        Windows.MessageBox(0, PChar(E.Message), 'Error',
          MB_OK or MB_ICONEXCLAMATION or MB_SYSTEMMODAL);
        Result := E_UNEXPECTED;
      end;
    end;
  finally
    FDataObject := nil;
    FFiles.Clear;
  end;
end;

function TDropContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
  idCmdLast, uFlags: UINT): HResult;
var
  i: integer;
  Last: integer;
  Flags: UINT;

  function IsLine(Item: TMenuItem): boolean;
  begin
  {$ifdef VER13_PLUS}
    Result := Item.IsLine;
  {$else}
    Result := Item.Caption = '-';
  {$endif}
  end;

begin
  Last := 0;

  if (FContextMenu <> nil) and (((uFlags and $0000000F) = CMF_NORMAL) or
     ((uFlags and CMF_EXPLORE) <> 0)) then
  begin
    FMenuOffset := idCmdFirst;
    for i := 0 to FContextMenu.Items.Count-1 do
      if (FContextMenu.Items[i].Visible) then
      begin
        Flags := MF_STRING or MF_BYPOSITION;
        if (not FContextMenu.Items[i].Enabled) then
          Flags := Flags or MF_GRAYED;
        if (IsLine(FContextMenu.Items[i])) then
          Flags := Flags or MF_SEPARATOR;
        // Add one menu item to context menu
        InsertMenu(Menu, indexMenu, Flags, FMenuOffset+i,
          PChar(FContextMenu.Items[i].Caption));
        inc(indexMenu);
        Last := i+1;
      end;
  end else
    FMenuOffset := 0;

  // Return number of menu items added
  Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, Last)
end;

function TDropContextMenu.Initialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
begin
  FFiles.Clear;

  if (lpdobj = nil) then
  begin
    Result := E_INVALIDARG;
    Exit;
  end;

  // Save a reference to the source data object.
  FDataObject := lpdobj;

  // Extract source file names and store them in a string list.
  with TFileDataFormat.Create(nil) do
    try
      if GetData(DataObject) then
        FFiles.Assign(Files);
    finally
      Free;
    end;

  if (Assigned(FOnPopup)) then
    FOnPopup(Self);

  Result := NOERROR;
end;

procedure TDropContextMenu.SetContextMenu(const Value: TPopupMenu);
begin
  if (Value <> FContextMenu) then
  begin
    if (FContextMenu <> nil) then
      FContextMenu.RemoveFreeNotification(Self);
    FContextMenu := Value;
    if (Value <> nil) then
      Value.FreeNotification(Self);
  end;
end;

procedure TDropContextMenu.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  if (Operation = opRemove) and (AComponent = FContextMenu) then
    FContextMenu := nil;
  inherited;
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TDropContextMenuFactory
//
////////////////////////////////////////////////////////////////////////////////
function TDropContextMenuFactory.HandlerRegSubKey: string;
begin
  Result := 'ContextMenuHandlers';
end;

procedure TDropContextMenuFactory.UpdateRegistry(Register: Boolean);
var
  ClassIDStr: string;
begin
  ClassIDStr := GUIDToString(ClassID);
  if Register then
  begin
    inherited UpdateRegistry(Register);
    CreateRegKey(FileClass+'\shellex\'+HandlerRegSubKey+'\'+ClassName, '', ClassIDStr);

    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      with TRegistry.Create do
        try
          RootKey := HKEY_LOCAL_MACHINE;
          OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
          OpenKey('Approved', True);
          WriteString(ClassIDStr, Description);
        finally
          Free;
        end;
  end else
  begin
    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      with TRegistry.Create do
        try
          RootKey := HKEY_LOCAL_MACHINE;
          OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
          OpenKey('Approved', True);
          DeleteKey(ClassIDStr);
        finally
          Free;
        end;
    DeleteRegKey(FileClass+'\shellex\'+HandlerRegSubKey+'\'+ClassName);
    inherited UpdateRegistry(Register);
  end;
end;

end.