RealICQClient/Includes/DRAGDROP/Demo/ShellContextMenuHandler/ContextMenuHandlerMain.pas

unit ContextMenuHandlerMain;

interface

uses
  DragDrop, DropTarget, DragDropContext,
  Forms, ShlObj, SysUtils, Classes, Menus;

{$include '..\..\Components\DragDrop.inc'}

{$ifndef VER13_PLUS}
type
  TDataModule = TForm;
{$endif}

type
  TDataModuleContextMenuHandler = class(TDataModule, IUnknown, IShellExtInit, IContextMenu)
    DropContextMenu1: TDropContextMenu;
    PopupMenu1: TPopupMenu;
    MenuCompile: TMenuItem;
    MenuLine1: TMenuItem;
    procedure MenuCompileClick(Sender: TObject);
    procedure DropContextMenu1Popup(Sender: TObject);
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    FFiles: TStrings;
  public
    // Aggregate IShellExtInit and IContextMenu to the TDropContextMenu component.
    property ContextMenuHandler: TDropContextMenu read DropContextMenu1
      implements IShellExtInit, IContextMenu;
  end;

implementation

{$R *.DFM}

uses
  Windows,
  ComServ,
  ComObj,
  Registry;

const
  // CLSID for this shell extension.
  // Modify this for your own shell extensions (press [Ctrl]+[Shift]+G in
  // the IDE editor to gererate a new CLSID).
  CLSID_ContextMenuHandler: TGUID = '{516EC4D3-4AD9-11D5-AA6A-00E0189008B3}';

resourcestring
  // Name of the file class we wish to operate on.
  sFileClass = 'DelphiProject';
  // The extension would normally have been '.dpr' (Delphi project), but since
  // we don't want to delete Delphi's file registration when we are uninstalled,
  // we specify an empty string as the extension and thus disable the
  // registration and unregistration of the file type.
  sFileExtension = '';

  // Class name of our shell extension.
  sClassName = 'DelphiProjectCompiler';
  // Description of our shell extension.
  sDescription = 'Drag and Drop Component Suite Context Menu demo';

  // File name replacement in case multiple files has been selected.
  sManyFiles = 'multiple projects';

// Returns string containing path to Delphi command line compiler.
function GetCompilerPath: string;
var
  Reg: TRegistry;
  Version: integer;
begin
  Reg := TRegistry.Create;
  try
    with Reg do
    begin
      RootKey := HKEY_LOCAL_MACHINE;

      // Locate higest version of Delphi in registry (v2 - v10).
      Version := 10;
      while (Version >= 3) and (not OpenKey(format('\SOFTWARE\Borland\Delphi\%d.0', [Version]), False)) do
        dec(Version);

      Result := ExpandFileName(ReadString('RootDir') + '\bin\dcc32.exe');
    end;
    if AnsiPos(' ', Result) <> 0 then
      Result := ExtractShortPathName(Result);
  finally
    Reg.Free;
  end;
end;

procedure TDataModuleContextMenuHandler.DataModuleCreate(Sender: TObject);
begin
  FFiles := TStringList.Create;
end;

procedure TDataModuleContextMenuHandler.DataModuleDestroy(Sender: TObject);
begin
  FFiles.Free;
end;

procedure TDataModuleContextMenuHandler.MenuCompileClick(Sender: TObject);

  procedure WinExecAndWait(const FileName, Parameters: string; Wait: boolean);
  var
    StartupInfo: TStartupInfo;
    ProcessInfo: TProcessInformation;
  begin
    FillChar(StartupInfo, Sizeof(StartupInfo),#0);
    StartupInfo.cb := Sizeof(StartupInfo);
    StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
    StartupInfo.wShowWindow := SW_SHOWDEFAULT;
    // Warning: Even though we could (and I would prefer to) call CreateProcess
    // like this:
    //   CreateProcess(PChar(FileName), PChar(Parameters), ...
    // a bug in Delphi's ParamStr function would cause the target application
    // to fail if we did so. The bug causes ParamStr(1) to "disappear".
    if (CreateProcess(nil, PChar(FileName+' '+Parameters), nil, nil, False,
      CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo,
      ProcessInfo)) then
    begin
      if (Wait) then
        // Wait 60 seconds then assume something went wrong and exit.
        WaitforSingleObject(ProcessInfo.hProcess, 60000);
    end;
  end;

var
  i: integer;
begin
  // Invoke Delphi command line compiler to compile each project in turn.
  for i := 0 to FFiles.Count-1 do
    WinExecAndWait(GetCompilerPath, ExtractShortPathName(FFiles[0]), True);
end;

procedure TDataModuleContextMenuHandler.DropContextMenu1Popup(Sender: TObject);
var
  i: integer;

  procedure ClearItem(Item: TMenuItem);
  begin
  {$ifdef VER13_PLUS}
    Item.Clear;
  {$else}
    while (Item.Count > 0) do
      Item[0].Free;
  {$endif}
  end;

begin
  // TDropContextMenu component now contains the files being dragged. Save them
  // for later use.
  FFiles.Assign(DropContextMenu1.Files);

  // Make sure that we only work on Delphi project files.
  for i := FFiles.Count-1 downto 0 do
    if (AnsiCompareText(ExtractFileExt(FFiles[i]), '.dpr') <> 0) then
      FFiles.Delete(i);

  // Insert source filename(s) into menu.
  if (FFiles.Count = 1) then
    MenuCompile.Caption := format(MenuCompile.Caption, [ExtractFileName(FFiles[0])])
  else if (FFiles.Count > 1) then
    MenuCompile.Caption := format(MenuCompile.Caption, [sManyFiles])
  else
    ClearItem(PopupMenu1.Items);
end;

initialization
  TDropContextMenuFactory.Create(ComServer, TDataModuleContextMenuHandler,
    CLSID_ContextMenuHandler, sClassName, sDescription, sFileClass,
    sFIleExtension, ciMultiInstance);
end.