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.