propsheet.pas

详细讲述如何用delphi进行com编程

unit PropSheet;

interface

uses
  Windows, Messages, ActiveX, ComObj, CommCtrl, ShlObj;

type
  TPropertySheet = class(TComObject, IShellExtInit, IShellPropSheetExt)
  private
    FFileName: WideString;

    function IShellExtInit.Initialize = InitShellExtension;
  protected
    {Declare IShellExtInit methods here}
    function InitShellExtension(pidlFolder: PItemIDList;
      lpdobj: IDataObject; hKeyProgID: HKEY): HResult; stdcall;

    {Declare IShellPropSheetExt methods here}
    function AddPages(lpfnAddPage: TFNAddPropSheetPage; lParam: LPARAM): HResult; stdcall;
    function ReplacePage(uPageID: UINT; lpfnReplaceWith: TFNAddPropSheetPage;
      lParam: LPARAM): HResult; stdcall;
  end;

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

const
  Class_PropertySheet: TGUID = '{D01C8F61-264B-11D3-B7FE-0040F67455FE}';

implementation

uses Classes, SysUtils, ComServ, ShellAPI, AXCtrls;

const
  IDD_CARPROPS     = 106;
  IDC_VEHICLENAME  = 1000;
  IDC_MODELYEAR    = 1001;

{$R PPAGE.RES}

function PropertySheetDlgProc(hDlg: HWND; uMessage: UINT;
  wParam: WPARAM; lParam: LPARAM): Boolean; stdcall;
var
  psp: PPropSheetPage;
  ps: TPropertySheet;
  stgRoot: IStorage;
  stmInfo: IStream;
  Res: HResult;
  OS: TOleStream;
  Reader: TReader;
  VehicleName: string;
  ModelYear: Integer;
begin
  Result := True;

  case uMessage of
    WM_INITDIALOG: begin
      psp := PPropSheetPage(lParam);
      ps := TPropertySheet(psp.lParam);

      Res := StgOpenStorage(PWideChar(ps.FFileName), nil, STGM_READ or
        STGM_SHARE_EXCLUSIVE, nil, 0, stgRoot);
      if SUCCEEDED(Res) then begin
        Res := stgRoot.OpenStream('Info', nil, STGM_READ or
          STGM_SHARE_EXCLUSIVE, 0, stmInfo);
        if SUCCEEDED(Res) then begin
          OS := TOleStream.Create(stmInfo);
          try
            Reader := TReader.Create(OS, 1024);
            try
              VehicleName := Reader.ReadString;
              ModelYear := Reader.ReadInteger;
            finally
              Reader.Free;
            end;
          finally
            OS.Free;
          end;

          SetDlgItemText(hDlg, IDC_VEHICLENAME, PChar(VehicleName));
          SetDlgItemText(hDlg, IDC_MODELYEAR, PChar(IntToStr(ModelYear)));
        end;
      end;
    end;

    WM_COMMAND: begin
      // If you have buttons on your dialog, you can handle
      // button presses here...
    end;

    WM_NOTIFY: begin
      case PNMHDR(lParam).code of
        PSN_APPLY: begin
          // The user clicked the OK or apply button.
        end;
      end;
    end;

    else
      Result := False;
  end;
end;

function PropertySheetCallback(hWnd: HWND; uMessage: UINT;
  var psp: TPropSheetPage): UINT; stdcall;
begin
  case uMessage of
    PSPCB_RELEASE:
      if psp.lParam <> 0 then
        TPropertySheet(psp.lParam)._Release;
  end;

  Result := 1;
end;

{ TPropertySheet }

function TPropertySheet.InitShellExtension(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
var
  Medium: TStgMedium;
  Format: TFormatEtc;
  FileName: string;
begin
  // Fail if no data object was provided
  if lpdobj = nil then begin
    Result := E_FAIL;
    exit;
  end;

  // Set up the TFormatEtc structure...
  with Format do begin
    cfFormat := CF_HDROP;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lIndex := -1;
    tymed := TYMED_HGLOBAL;
  end;

  // Fail if we can't get to the data
  Result := lpdobj.GetData(Format, Medium);
  if Failed(Result) then
    exit;

  try
    // Make sure the user only selected one file
    if DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then begin
      SetLength(FileName, MAX_PATH);
      DragQueryFile(Medium.hGlobal, 0, PChar(FileName), MAX_PATH);
      FFileName := FileName;
      Result := NOERROR;
    end else
      Result := E_FAIL;
  finally
    ReleaseStgMedium(Medium);
  end;
end;

function TPropertySheet.AddPages(lpfnAddPage: TFNAddPropSheetPage;
  lParam: LPARAM): HResult;
var
  psp: TPropSheetPage;
  hPage: HPropSheetPage;
begin
  FillChar(psp, sizeof(psp), 0);
  psp.dwSize := sizeof(psp);
  psp.dwFlags := PSP_USETITLE or PSP_USECALLBACK;
  psp.hInstance := hInstance;
  psp.pszTemplate := MAKEINTRESOURCE(IDD_CARPROPS);
  psp.pszTitle := 'Car Information';
  psp.pfnDlgProc := @PropertySheetDlgProc;
  psp.pfnCallback := @PropertySheetCallback;
  psp.lParam := Integer(self);

  hPage := CreatePropertySheetPage(psp);

  if hPage <> nil then begin
    if not lpfnAddPage(hPage, lParam) then
      DestroyPropertySheetPage(hPage);
  end;

  _AddRef;

  Result := NOERROR;
end;

function TPropertySheet.ReplacePage(uPageID: UINT;
  lpfnReplaceWith: TFNAddPropSheetPage; lParam: LPARAM): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TPropertySheetFactory }

procedure TPropertySheetFactory.UpdateRegistry(Register: Boolean);
begin
  inherited UpdateRegistry(Register);

  if Register then begin
    CreateRegKey('.car', '', 'CarDemo');
    CreateRegKey('CarDemo\shellex\PropertySheetHandlers\' +
      ClassName, '', GUIDToString(ClassID));
  end else begin
    DeleteRegKey('CarDemo\shellex\PropertySheetHandlers\' +
      ClassName);
  end;
end;

initialization
{$IFDEF VER100}
  TPropertySheetFactory.Create(ComServer, TPropertySheet, Class_PropertySheet,
    'PropertySheet', '', ciMultiInstance);
{$ELSE}
  TPropertySheetFactory.Create(ComServer, TPropertySheet, Class_PropertySheet,
    'PropertySheet', '', ciMultiInstance, tmApartment);
{$ENDIF}
end.