axctrls.pas

这是不可多得的源代码

    property MiscStatus: Integer read FMiscStatus;
    property ToolboxBitmapID: Integer read FToolboxBitmapID;
    property WinControlClass: TWinControlClass read FWinControlClass;
  end;
  {$EXTERNALSYM TActiveXControlFactory}

  { ActiveFormControl }

  TActiveFormControl = class(TActiveXControl, IVCLComObject)
  protected
    procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
  public
    procedure FreeOnRelease;
    procedure InitializeControl; override;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
      override;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
  end;
  {$EXTERNALSYM TActiveFormControl}

  { ActiveForm }

  TActiveForm = class(TCustomActiveForm)
  private
    FSinkChangeCount : Integer;
    FActiveFormControl: TActiveFormControl;
  protected
    procedure DoDestroy; override;
    procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); virtual;
    procedure EventSinkChanged(const EventSink: IUnknown); virtual;
    procedure Initialize; virtual;
  public
    property ActiveFormControl: TActiveFormControl read FActiveFormControl;
  end;
  {$EXTERNALSYM TActiveForm}

  TActiveFormClass = class of TActiveForm;
  {$EXTERNALSYM TActiveFormClass}

  { ActiveFormFactory }

  TActiveFormFactory = class(TActiveXControlFactory)
  public
    function GetIntfEntry(Guid: TGUID): PInterfaceEntry; override;
  end;
  {$EXTERNALSYM TActiveFormFactory}

  { Property Page support }

  TPropertyPageImpl = class;

  TPropertyPage = class(TCustomForm)
  private
    FActiveXPropertyPage: TPropertyPageImpl;
    FOleObject: OleVariant;
    FOleObjects: TInterfaceList;
    procedure CMChanged(var Msg: TCMChanged); message CM_CHANGED;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Modified;
    procedure UpdateObject; virtual;
    procedure UpdatePropertyPage; virtual;
    property OleObject: OleVariant read FOleObject;
    property OleObjects: TInterfaceList read FOleObjects write FOleObjects;
    procedure EnumCtlProps(PropType: TGUID; PropNames: TStrings);
  published
    property ActiveControl;
    property AutoScroll;
    property Caption;
    property ClientHeight;
    property ClientWidth;
    property Ctl3D;
    property Color;
    property Enabled;
    property Font;
    property Height;
    property HorzScrollBar;
    property OldCreateOrder;
    property KeyPreview;
    property PixelsPerInch;
    property ParentFont;
    property PopupMenu;
    property PrintScale;
    property Scaled;
    property ShowHint;
    property VertScrollBar;
    property Visible;
    property Width;
    property OnActivate;
    property OnClick;
    property OnClose;
    property OnContextPopup;
    property OnCreate;
    property OnDblClick;
    property OnDestroy;
    property OnDeactivate;
    property OnDragDrop;
    property OnDragOver;
    property OnHide;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnPaint;
    property OnResize;
    property OnShow;
  end;

  TPropertyPageClass = class of TPropertyPage;

  TPropertyPageImpl = class(TAggregatedObject, IUnknown, IPropertyPage, IPropertyPage2)
  private
    FPropertyPage: TPropertyPage;
    FPageSite: IPropertyPageSite;
    FActive: Boolean;
    FModified: Boolean;
    procedure Modified;
  protected
    { IPropertyPage }
    function SetPageSite(const pageSite: IPropertyPageSite): HResult; stdcall;
    function Activate(hwndParent: HWnd; const rc: TRect; bModal: BOOL): HResult;
      stdcall;
    function Deactivate: HResult; stdcall;
    function GetPageInfo(out pageInfo: TPropPageInfo): HResult; stdcall;
    function SetObjects(cObjects: Longint; pUnkList: PUnknownList): HResult; stdcall;
    function Show(nCmdShow: Integer): HResult; stdcall;
    function Move(const rect: TRect): HResult; stdcall;
    function IsPageDirty: HResult; stdcall;
    function Apply: HResult; stdcall;
    function Help(pszHelpDir: POleStr): HResult; stdcall;
    function TranslateAccelerator(msg: PMsg): HResult; stdcall;
    { IPropertyPage2 }
    function EditProperty(dispid: TDispID): HResult; stdcall;
  public
    procedure InitPropertyPage; virtual;
    property PropertyPage: TPropertyPage read FPropertyPage write FPropertyPage;
  end;

  TActiveXPropertyPage = class(TComObject, IPropertyPage, IPropertyPage2)
  private
    FPropertyPageImpl: TPropertyPageImpl;
  public
    destructor Destroy; override;
    procedure Initialize; override;
    property PropertyPageImpl: TPropertyPageImpl read FPropertyPageImpl
      implements IPropertyPage, IPropertyPage2;
  end;
  {$EXTERNALSYM TActiveXPropertyPage}

  TActiveXPropertyPageFactory = class(TComObjectFactory)
  public
    constructor Create(ComServer: TComServerObject;
      PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
    function CreateComObject(const Controller: IUnknown): TComObject; override;
  end;
  {$EXTERNALSYM TActiveXPropertyPageFactory}

  { Type adapter support }

  TCustomAdapter = class(TInterfacedObject)
  private
    FOleObject: IUnknown;
    FConnection: Longint;
    FNotifier: IUnknown;
  protected
    Updating: Boolean;
    procedure Changed; virtual;
    procedure ConnectOleObject(OleObject: IUnknown);
    procedure ReleaseOleObject;
    procedure Update; virtual; abstract;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TAdapterNotifier = class(TInterfacedObject,
    IPropertyNotifySink)
  private
    FAdapter: TCustomAdapter;
  protected
    { IPropertyNotifySink }
    function OnChanged(dispid: TDispID): HResult; stdcall;
    function OnRequestEdit(dispid: TDispID): HResult; stdcall;
  public
    constructor Create(Adapter: TCustomAdapter);
  end;

  IFontAccess = interface
    ['{CBA55CA0-0E57-11D0-BD2F-0020AF0E5B81}']
    procedure GetOleFont(var OleFont: IFontDisp);
    procedure SetOleFont(const OleFont: IFontDisp);
  end;

  TFontAdapter = class(TCustomAdapter,
    IChangeNotifier,
    IFontAccess)
  private
    FFont: TFont;
  protected
    { IFontAccess }
    procedure GetOleFont(var OleFont: IFontDisp);
    procedure SetOleFont(const OleFont: IFontDisp);
    procedure Changed; override;
    procedure Update; override;
  public
    constructor Create(Font: TFont);
  end;

  IPictureAccess = interface
    ['{795D4D31-43D7-11D0-9E92-0020AF3D82DA}']
    procedure GetOlePicture(var OlePicture: IPictureDisp);
    procedure SetOlePicture(const OlePicture: IPictureDisp);
  end;

  TPictureAdapter = class(TCustomAdapter,
    IChangeNotifier,
    IPictureAccess)
  private
    FPicture: TPicture;
  protected
    { IPictureAccess }
    procedure GetOlePicture(var OlePicture: IPictureDisp);
    procedure SetOlePicture(const OlePicture: IPictureDisp);
    procedure Update; override;
  public
    constructor Create(Picture: TPicture);
  end;

  TOleGraphic = class(TGraphic)
  private
    FPicture: IPicture;
    function GetMMHeight: Integer;
    function GetMMWidth: Integer;
  protected
    procedure Changed(Sender: TObject); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetPalette: HPALETTE; override;
    function GetTransparent: Boolean; override;
    function GetWidth: Integer; override;
    procedure SetHeight(Value: Integer); override;
    procedure SetPalette(Value: HPALETTE); override;
    procedure SetWidth(Value: Integer); override;
  public
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromFile(const Filename: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    property MMHeight: Integer read GetMMHeight;      // in .01 mm units
    property MMWidth: Integer read GetMMWidth;
    property Picture: IPicture read FPicture write FPicture;
  end;

  TStringsAdapter = class(TAutoIntfObject, IStrings, IStringsAdapter)
  private
    FStrings: TStrings;
  protected
    { IStringsAdapter }
    procedure ReferenceStrings(S: TStrings);
    procedure ReleaseStrings;
    { IStrings }
    function Get_ControlDefault(Index: Integer): OleVariant; safecall;
    procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall;
    function Count: Integer; safecall;
    function Get_Item(Index: Integer): OleVariant; safecall;
    procedure Set_Item(Index: Integer; Value: OleVariant); safecall;
    procedure Remove(Index: Integer); safecall;
    procedure Clear; safecall;
    function Add(Item: OleVariant): Integer; safecall;
    function _NewEnum: IUnknown; safecall;
  public
    constructor Create(Strings: TStrings);
  end;

  TReflectorWindow = class(TWinControl)
  private
    FControl: TControl;
    FInSize: Boolean;
    procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(ParentWindow: HWND; Control: TControl); reintroduce;
  end;

procedure EnumDispatchProperties(Dispatch: IDispatch; PropType: TGUID;
  VTCode: Integer; PropList: TStrings);

procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
procedure SetOleFont(Font: TFont; OleFont: IFontDisp);
procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
procedure SetOlePicture(Picture: TPicture; OlePicture: IPictureDisp);
procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
procedure SetOleStrings(Strings: TStrings; OleStrings: IStrings);

function ParkingWindow: HWND;

implementation

uses Consts;

const
  OCM_BASE = $2000;

type
  TWinControlAccess = class(TWinControl);

  IStdEvents = dispinterface
    ['{00020400-0000-0000-C000-000000000046}']
    procedure Click; dispid DISPID_CLICK;
    procedure DblClick; dispid DISPID_DBLCLICK;
    procedure KeyDown(var KeyCode: Smallint;
      Shift: Smallint); dispid DISPID_KEYDOWN;
    procedure KeyPress(var KeyAscii: Smallint); dispid DISPID_KEYPRESS;
    procedure KeyUp(var KeyCode: Smallint;
      Shift: Smallint); dispid DISPID_KEYDOWN;
    procedure MouseDown(Button, Shift: Smallint;
      X, Y: Integer); dispid DISPID_MOUSEDOWN;
    procedure MouseMove(Button, Shift: Smallint;
      X, Y: Integer); dispid DISPID_MOUSEMOVE;
    procedure MouseUp(Button, Shift: Smallint;
      X, Y: Integer); dispid DISPID_MOUSEUP;
  end;

var
  xParkingWindow: HWND;

{ Dynamically load functions used in OLEPRO32.DLL }

function OleCreatePropertyFrame(hwndOwner: HWnd; x, y: Integer;
  lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  pvReserved: Pointer): HResult; forward;
function OleCreateFontIndirect(const FontDesc: TFontDesc; const iid: TIID;
  out vObject): HResult; forward;
function OleCreatePictureIndirect(const PictDesc: TPictDesc; const iid: TIID;
  fOwn: BOOL; out vObject): HResult; forward;
function OleLoadPicture(stream: IStream; lSize: Longint; fRunmode: BOOL;
  const iid: TIID; out vObject): HResult; forward;


function ParkingWindowProc(Wnd: HWND; Msg, wParam, lParam: Longint): Longint; stdcall;
var
  ControlWnd: HWND;
begin
  case Msg of
    WM_COMPAREITEM, WM_DELETEITEM, WM_DRAWITEM, WM_MEASUREITEM, WM_COMMAND:
      begin
        case Msg of
          WM_COMPAREITEM: ControlWnd := PCompareItemStruct(lParam).CtlID;
          WM_DELETEITEM:  ControlWnd := PDeleteItemStruct(lParam).CtlID;
          WM_DRAWITEM:    ControlWnd := PDrawItemStruct(lParam).CtlID;
          WM_MEASUREITEM: ControlWnd := PMeasureItemStruct(lParam).CtlID;
          WM_COMMAND:     ControlWnd := HWND(lParam);
        else
          Result := 0;
          Exit;
        end;
        Result := SendMessage(ControlWnd, OCM_BASE + Msg, wParam, lParam);
      end;
  else
    if (Msg = WM_NCDESTROY) and (Wnd = xParkingWindow) then xParkingWindow := 0;
    Result := DefWindowProc(Wnd, Msg, WParam, LParam);
  end;
end;

function ParkingWindow: HWND;
var
  TempClass: TWndClass;
begin
  Result := xParkingWindow;
  if Result <> 0 then Exit;

  FillChar(TempClass, sizeof(TempClass), 0);
  if not GetClassInfo(HInstance, 'DAXParkingWindow', TempClass) then
  begin
    TempClass.hInstance := HInstance;
    TempClass.lpfnWndProc := @ParkingWindowProc;
    TempClass.lpszClassName := 'DAXParkingWindow';
    if Windows.RegisterClass(TempClass) = 0 then
      raise EOutOfResources.Create(SWindowClass);
  end;
  xParkingWindow := CreateWindowEx(WS_EX_TOOLWINDOW, TempClass.lpszClassName, nil,
    WS_POPUP, GetSystemMetrics(SM_CXSCREEN) div 2,
    GetSystemMetrics(SM_CYSCREEN) div 2, 0, 0, 0, 0, HInstance, nil);
  SetWindowPos(xParkingWindow, 0, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOREDRAW
    or SWP_NOZORDER or SWP_SHOWWINDOW);
  Result := xParkingWindow;
end;

function HandleException: HResult;
var
  E: TObject;
begin
  E := ExceptObject;