contextmenuimpl.pas

这是一个DELPHI7应用案例开发篇有配套程序种子光盘

unit ContextMenuImpl;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, ContentMenu_TLB, StdVcl, ShlObj, Windows;

type
  TDFMContextMenu = class(TAutoObject, IDFMContextMenu, IShellExtInit, IContextMenu)
  protected
    FFileName: array[0..MAX_PATH] of Char;
    function IShellExtInit.Initialize = SHEInitialize;
    function SHEInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;

    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;

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


implementation

uses ComServ, ShellAPI, Registry, SysUtils, Dialogs;

{ TDFMContextMenu }

function TDFMContextMenu.GetCommandString(idCmd, uType: UINT;
  pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;
begin
    if (idCmd = 0) then
    begin
        if (uType = GCS_HELPTEXT) then
        {返回该菜单项的帮助信息，此帮助信息将在用户把鼠标移动到该菜单项时出现在状态条上。}
            StrCopy(pszName, PChar('编译'+FFileName));
            
        Result := NOERROR;
    end
    else
        Result := E_INVALIDARG;
end;

function TDFMContextMenu.SHEInitialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
var
     StgMedium: TStgMedium;
     FormatEtc: TFormatEtc;
begin
    //如果lpdobj等于Nil，则本调用失败
    if (lpdobj = nil) then begin
        Result := E_INVALIDARG;
        Exit;
    end;
    with FormatEtc do begin
        cfFormat := CF_HDROP;
        ptd := nil;
        dwAspect := DVASPECT_CONTENT;
        lindex := -1;
        tymed := TYMED_HGLOBAL;
    end;
    Result := lpdobj.GetData(FormatEtc, StgMedium);

    if Failed(Result) then Exit;

    {用DragQueryFile函数来查询选定的文件的个数。本例中仅当只选定
    一个文件时才在上下文相关菜单中增加菜单项。}
    if (DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0) = 1) then
    begin
        DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
        Result := NOERROR;
    end
    else begin
        FFileName := '';
        Result := E_FAIL;
    end;
    ReleaseStgMedium(StgMedium);
end;


function TDFMContextMenu.InvokeCommand(
  var lpici: TCMInvokeCommandInfo): HResult;
var
    H: THandle;
    DelphiPath:String;
    Reg:TRegistry;
begin
    // Make sure we are not being called by an application
    if (HiWord(Integer(lpici.lpVerb)) <> 0) or
        (FFileName='') then
    begin
        Result := E_FAIL;
        Exit;
    end;

    Reg:=TRegistry.Create;
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKeyReadOnly('Software\Borland\Delphi\7.0');
    DelphiPath:=Reg.ReadString('RootDir');
    Reg.Free;

    DelphiPath := DelphiPath+'\Bin\Dcc32.exe';

    H := WinExec(PChar('"'+DelphiPath+'"'+' ' +'"'+FFileName+'"'), lpici.nShow);
    if (H < 32) then
    begin
        MessageBox(lpici.hWnd, PChar('执行DCC32.EXE时出错！'+#13#10+DelphiPath)
            , '错误', MB_ICONERROR+MB_OK);
    end;

    Result := NOERROR;
end;

function TDFMContextMenu.QueryContextMenu(Menu: HMENU; indexMenu,
  idCmdFirst, idCmdLast, uFlags: UINT): HResult;
begin
    Result := 0;
    if ((uFlags and $0000000F) = CMF_NORMAL) or
    ((uFlags and CMF_EXPLORE) <> 0) then
    begin
        // 往Context Menu中加入一个菜单项
        InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
        PChar('编译'+ExtractFileName(FFileName)));
        // 返回增加菜单项的个数
        Result := 1;
    end;
end;

{ TContextMenuFactory }

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
     ClassID: string;
const
  SApproveKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved';
begin
    inherited;
    ClassID := GUIDToString(Class_DFMContextMenu);

    if Register then
    begin
//        CreateRegKey('DelphiProject\shellex', '', '');
//        CreateRegKey('DelphiProject\shellex\ContextMenuHandlers', '', '');
        CreateRegKey('DelphiProject\shellex\ContextMenuHandlers\OpenWithDelphi', '', ClassID);
        //如果操作系统为Windows NT的话
        if (Win32Platform = VER_PLATFORM_WIN32_NT) then
            with TRegistry.Create do
            try
                RootKey := HKEY_LOCAL_MACHINE;
                if not OpenKey(SApproveKey, True) then Exit;
                WriteString(ClassID, 'Delphi Project Shell Extension');
            finally
                Free;
            end;
    end
    else begin
        DeleteRegKey('DelphiProject\shellex\ContextMenuHandlers\OpenWithDelphi');
        if (Win32Platform = VER_PLATFORM_WIN32_NT) then
            with TRegistry.Create do
            try
                RootKey := HKEY_LOCAL_MACHINE;
                if not OpenKey(SApproveKey, True) then Exit;
                DeleteValue(ClassID);
            finally
                Free;
            end;
    end;
end;

initialization
  TContextMenuFactory.Create(ComServer, TDFMContextMenu, Class_DFMContextMenu,
    ciMultiInstance, tmApartment);
end.