axctrls.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       ActiveX Controls Unit                           }
{                                                       }
{  Copyright (c) 1995-2001 Borland Software Corporation }
{                                                       }
{*******************************************************}

unit AxCtrls;

{$WARN SYMBOL_PLATFORM OFF}

{$T-,H+,X+}

interface

(*$HPPEMIT '' *)
(*$HPPEMIT '#include <objsafe.h>' *)
(*$HPPEMIT '#include <ocidl.h>' *)
(*$HPPEMIT '' *)

uses
  Variants, Windows, Messages, ActiveX, SysUtils, {$IFDEF LINUX} WinUtils, {$ENDIF}
  ComObj, Classes, Graphics, Controls, Forms, ExtCtrls, StdVCL;

const
  { Delphi property page CLSIDs }
  Class_DColorPropPage: TGUID = '{5CFF5D59-5946-11D0-BDEF-00A024D1875C}';
  Class_DFontPropPage: TGUID = '{5CFF5D5B-5946-11D0-BDEF-00A024D1875C}';
  Class_DPicturePropPage: TGUID = '{5CFF5D5A-5946-11D0-BDEF-00A024D1875C}';
  Class_DStringPropPage: TGUID = '{F42D677E-754B-11D0-BDFB-00A024D1875C}';

type
  TOleStream = class(TStream)
  private
    FStream: IStream;
  protected
    function GetIStream: IStream;
  public
    constructor Create(const Stream: IStream);
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
  end;

  TConnectionPoints = class;

  TConnectionKind = (ckSingle, ckMulti);
  {$EXTERNALSYM TConnectionKind}

  TConnectionPoint = class(TContainedObject, IConnectionPoint)
  private
    FContainer: TConnectionPoints;
    FIID: TGUID;
    FSinkList: TList;
    FOnConnect: TConnectEvent;
    FKind: TConnectionKind;
    function AddSink(const Sink: IUnknown): Integer;
    procedure RemoveSink(Cookie: Longint);
  protected
    { IConnectionPoint }
    function GetConnectionInterface(out iid: TIID): HResult; stdcall;
    function GetConnectionPointContainer(
      out cpc: IConnectionPointContainer): HResult; stdcall;
    function Advise(const unkSink: IUnknown; out dwCookie: Longint): HResult; stdcall;
    function Unadvise(dwCookie: Longint): HResult; stdcall;
    function EnumConnections(out enumconn: IEnumConnections): HResult; stdcall;
  public
    constructor Create(Container: TConnectionPoints;
      const IID: TGUID; Kind: TConnectionKind; OnConnect: TConnectEvent);
    property SinkList : TList read FSinkList;
    destructor Destroy; override;
  end;
  {$EXTERNALSYM TConnectionPoint}

  TConnectionPoints = class{IConnectionPointContainer}
  private
    FController: Pointer;  // weak ref to controller - don't keep it alive
    FConnectionPoints: TList;
    function GetController: IUnknown;
  protected
    { IConnectionPointContainer }
    function EnumConnectionPoints(
      out enumconn: IEnumConnectionPoints): HResult; stdcall;
    function FindConnectionPoint(const iid: TIID;
      out cp: IConnectionPoint): HResult; stdcall;
  public
    constructor Create(const AController: IUnknown);
    destructor Destroy; override;
    function CreateConnectionPoint(const IID: TGUID; Kind: TConnectionKind;
      OnConnect: TConnectEvent): TConnectionPoint;
    property Controller: IUnknown read GetController;
  end;
  {$EXTERNALSYM TConnectionPoints}

  TDefinePropertyPage = procedure(const GUID: TGUID) of object;

  TActiveXControlFactory = class;
  {$EXTERNALSYM TActiveXControlFactory}

  IAmbientDispatch = dispinterface
    ['{00020400-0000-0000-C000-000000000046}']
    property BackColor: Integer dispid DISPID_AMBIENT_BACKCOLOR;
    property DisplayName: WideString dispid DISPID_AMBIENT_DISPLAYNAME;
    property Font: IFontDisp dispid DISPID_AMBIENT_FONT;
    property ForeColor: Integer dispid DISPID_AMBIENT_FORECOLOR;
    property LocaleID: Integer dispid DISPID_AMBIENT_LOCALEID;
    property MessageReflect: WordBool dispid DISPID_AMBIENT_MESSAGEREFLECT;
    property ScaleUnits: WideString dispid DISPID_AMBIENT_SCALEUNITS;
    property TextAlign: Smallint dispid DISPID_AMBIENT_TEXTALIGN;
    property UserMode: WordBool dispid DISPID_AMBIENT_USERMODE;
    property UIDead: WordBool dispid DISPID_AMBIENT_UIDEAD;
    property ShowGrabHandles: WordBool dispid DISPID_AMBIENT_SHOWGRABHANDLES;
    property ShowHatching: WordBool dispid DISPID_AMBIENT_SHOWHATCHING;
    property DisplayAsDefault: WordBool dispid DISPID_AMBIENT_DISPLAYASDEFAULT;
    property SupportsMnemonics: WordBool dispid DISPID_AMBIENT_SUPPORTSMNEMONICS;
    property AutoClip: WordBool dispid DISPID_AMBIENT_AUTOCLIP;
  end;

  TActiveXControl = class(TAutoObject,
    IConnectionPointContainer,
    IDataObject,
    IObjectSafety,
    IOleControl,
    IOleInPlaceActiveObject,
    IOleInPlaceObject,
    IOleObject,
    IPerPropertyBrowsing,
    IPersistPropertyBag,
    IPersistStorage,
    IPersistStreamInit,
    IQuickActivate,
    ISimpleFrameSite,
    ISpecifyPropertyPages,
    IViewObject,
    IViewObject2)

  private
    FControlFactory: TActiveXControlFactory;
    FConnectionPoints: TConnectionPoints;
    FPropertySinks: TConnectionPoint;
    FObjectSafetyFlags: DWORD;
    FOleClientSite: IOleClientSite;
    FOleControlSite: IOleControlSite;
    FSimpleFrameSite: ISimpleFrameSite;
    FAmbientDispatch: IAmbientDispatch;
    FOleInPlaceSite: IOleInPlaceSite;
    FOleInPlaceFrame: IOleInPlaceFrame;
    FOleInPlaceUIWindow: IOleInPlaceUIWindow;
    FOleAdviseHolder: IOleAdviseHolder;
    FDataAdviseHolder: IDataAdviseHolder;
    FAdviseSink: IAdviseSink;
    FAdviseFlags: Integer;
    FControl: TWinControl;
    FControlWndProc: TWndMethod;
    FWinControl: TWinControl;
    FIsDirty: Boolean;
    FInPlaceActive: Boolean;
    FUIActive: Boolean;
    FEventsFrozen: Boolean;
    FOleLinkStub: IInterface; // Pointer to a TOleLinkStub instance
    function CreateAdviseHolder: HResult;
    function GetPropertyID(const PropertyName: WideString): Integer;
    procedure RecreateWnd;
    procedure ViewChanged;
  protected
    { Renamed methods }
    function IPersistPropertyBag.InitNew = PersistPropBagInitNew;
    function IPersistPropertyBag.Load = PersistPropBagLoad;
    function IPersistPropertyBag.Save = PersistPropBagSave;
    function IPersistStreamInit.Load = PersistStreamLoad;
    function IPersistStreamInit.Save = PersistStreamSave;
    function IPersistStorage.InitNew = PersistStorageInitNew;
    function IPersistStorage.Load = PersistStorageLoad;
    function IPersistStorage.Save = PersistStorageSave;
    function IViewObject2.GetExtent = ViewObjectGetExtent;
    { IPersist }
    function GetClassID(out classID: TCLSID): HResult; stdcall;
    { IPersistPropertyBag }
    function PersistPropBagInitNew: HResult; stdcall;
    function PersistPropBagLoad(const pPropBag: IPropertyBag;
      const pErrorLog: IErrorLog): HResult; stdcall;
    function PersistPropBagSave(const pPropBag: IPropertyBag; fClearDirty: BOOL;
      fSaveAllProperties: BOOL): HResult; stdcall;
    { IPersistStreamInit }
    function IsDirty: HResult; stdcall;
    function PersistStreamLoad(const stm: IStream): HResult; stdcall;
    function PersistStreamSave(const stm: IStream;
      fClearDirty: BOOL): HResult; stdcall;
    function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
    function InitNew: HResult; stdcall;
    { IPersistStorage }
    function PersistStorageInitNew(const stg: IStorage): HResult; stdcall;
    function PersistStorageLoad(const stg: IStorage): HResult; stdcall;
    function PersistStorageSave(const stgSave: IStorage;
      fSameAsLoad: BOOL): HResult; stdcall;
    function SaveCompleted(const stgNew: IStorage): HResult; stdcall;
    function HandsOffStorage: HResult; stdcall;
    { IObjectSafety }
    function GetInterfaceSafetyOptions(const IID: TIID; pdwSupportedOptions,
      pdwEnabledOptions: PDWORD): HResult; virtual; stdcall;
    function SetInterfaceSafetyOptions(const IID: TIID; dwOptionSetMask,
      dwEnabledOptions: DWORD): HResult; virtual; stdcall;
    { IOleObject }
    function SetClientSite(const clientSite: IOleClientSite): HResult;
      stdcall;
    function GetClientSite(out clientSite: IOleClientSite): HResult;
      stdcall;
    function SetHostNames(szContainerApp: POleStr;
      szContainerObj: POleStr): HResult; stdcall;
    function Close(dwSaveOption: Longint): HResult; stdcall;
    function SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
      stdcall;
    function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
      out mk: IMoniker): HResult; stdcall;
    function InitFromData(const dataObject: IDataObject; fCreation: BOOL;
      dwReserved: Longint): HResult; stdcall;
    function GetClipboardData(dwReserved: Longint;
      out dataObject: IDataObject): HResult; stdcall;
    function DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
      lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
      stdcall;
    function EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; stdcall;
    function Update: HResult; stdcall;
    function IsUpToDate: HResult; stdcall;
    function GetUserClassID(out clsid: TCLSID): HResult; stdcall;
    function GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
      stdcall;
    function SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
      stdcall;
    function GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
      stdcall;
    function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
      stdcall;
    function Unadvise(dwConnection: Longint): HResult; stdcall;
    function EnumAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
    function GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
      stdcall;
    function SetColorScheme(const logpal: TLogPalette): HResult; stdcall;
    { IOleControl }
    function GetControlInfo(var ci: TControlInfo): HResult; stdcall;
    function OnMnemonic(msg: PMsg): HResult; stdcall;
    function OnAmbientPropertyChange(dispid: TDispID): HResult; stdcall;
    function FreezeEvents(bFreeze: BOOL): HResult; stdcall;
    { IOleWindow }
    function GetWindow(out wnd: HWnd): HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    { IOleInPlaceObject }
    function InPlaceDeactivate: HResult; stdcall;
    function UIDeactivate: HResult; stdcall;
    function SetObjectRects(const rcPosRect: TRect;
      const rcClipRect: TRect): HResult; stdcall;
    function ReactivateAndUndo: HResult; stdcall;
    { IOleInPlaceActiveObject }
    function TranslateAccelerator(var msg: TMsg): HResult; stdcall;
    function OnFrameWindowActivate(fActivate: BOOL): HResult; stdcall;
    function OnDocWindowActivate(fActivate: BOOL): HResult; stdcall;
    function ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
      fFrameWindow: BOOL): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
    { IViewObject }
    function Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
      ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
      prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
      dwContinue: Longint): HResult; stdcall;
    function GetColorSet(dwDrawAspect: Longint; lindex: Longint;
      pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
      out colorSet: PLogPalette): HResult; stdcall;
    function Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
      out dwFreeze: Longint): HResult; stdcall;
    function Unfreeze(dwFreeze: Longint): HResult; stdcall;
    function SetAdvise(aspects: Longint; advf: Longint;
      const advSink: IAdviseSink): HResult; stdcall;
    function GetAdvise(pAspects: PLongint; pAdvf: PLONGINT;
      out advSink: IAdviseSink): HResult; stdcall;
    { IViewObject2 }
    function ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
      ptd: PDVTargetDevice; out size: TPoint): HResult; stdcall;
    { IPerPropertyBrowsing }
    function GetDisplayString(dispid: TDispID; out bstr: WideString): HResult; stdcall;
    function MapPropertyToPage(dispid: TDispID; out clsid: TCLSID): HResult; stdcall;
    function GetPredefinedStrings(dispid: TDispID; out caStringsOut: TCAPOleStr;
      out caCookiesOut: TCALongint): HResult; stdcall;
    function GetPredefinedValue(dispid: TDispID; dwCookie: Longint;
      out varOut: OleVariant): HResult; stdcall;
    { ISpecifyPropertyPages }
    function GetPages(out pages: TCAGUID): HResult; stdcall;
    { ISimpleFrameSite }
    function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
      out res: Integer; out Cookie: Longint): HResult; stdcall;
    function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
      out res: Integer; Cookie: Longint): HResult; stdcall;
    { IQuickActivate }
    function QuickActivate(var qaCont: tagQACONTAINER; var qaCtrl: tagQACONTROL): HResult; stdcall;
    function SetContentExtent(const sizel: TPoint): HResult; stdcall;
    function GetContentExtent(out sizel: TPoint): HResult; stdcall;
    { IDataObject }
    function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium):
      HResult; stdcall;
    function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium):
      HResult; stdcall;
    function QueryGetData(const formatetc: TFormatEtc): HResult;
      stdcall;
    function GetCanonicalFormatEtc(const formatetc: TFormatEtc;
      out formatetcOut: TFormatEtc): HResult; stdcall;
    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
      fRelease: BOOL): HResult; stdcall;
    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
      IEnumFormatEtc): HResult; stdcall;
    function DAdvise(const formatetc: TFormatEtc; advf: Longint;
      const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
    function DUnadvise(dwConnection: Longint): HResult; stdcall;
    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
      stdcall;
    { Standard properties }
    function Get_BackColor: Integer; safecall;
    function Get_Caption: WideString; safecall;
    function Get_Enabled: WordBool; safecall;
    function Get_Font: Font; safecall;
    function Get_ForeColor: Integer; safecall;
    function Get_HWnd: Integer; safecall;
    function Get_TabStop: WordBool; safecall;
    function Get_Text: WideString; safecall;
    procedure Set_BackColor(Value: Integer); safecall;
    procedure Set_Caption(const Value: WideString); safecall;
    procedure Set_Enabled(Value: WordBool); safecall;
    procedure Set_Font(const Value: Font); safecall;
    procedure Set_ForeColor(Value: Integer); safecall;
    procedure Set_TabStop(Value: WordBool); safecall;
    procedure Set_Text(const Value: WideString); safecall;
    { Standard event handlers }
    procedure StdClickEvent(Sender: TObject);
    procedure StdDblClickEvent(Sender: TObject);
    procedure StdKeyDownEvent(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure StdKeyPressEvent(Sender: TObject; var Key: Char);
    procedure StdKeyUpEvent(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure StdMouseDownEvent(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure StdMouseMoveEvent(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure StdMouseUpEvent(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    { Helper methods }
    function InPlaceActivate(ActivateUI: Boolean): HResult;
    procedure ShowPropertyDialog;
    procedure SetInPlaceSite(const NewInPlaceSite: IOleInPlaceSite);
    { Overrideable methods }
    procedure DefinePropertyPages(
      DefinePropertyPage: TDefinePropertyPage); virtual;
    function GetPropertyString(DispID: Integer;
      var S: string): Boolean; virtual;
    function GetPropertyStrings(DispID: Integer;
      Strings: TStrings): Boolean; virtual;
    procedure GetPropertyValue(DispID, Cookie: Integer;
      var Value: OleVariant); virtual;
    procedure GetPropFromBag(const PropName: WideString; DispatchID: Integer;
      PropBag: IPropertyBag; ErrorLog: IErrorLog); virtual;
    procedure InitializeControl; virtual;
    procedure LoadFromStream(const Stream: IStream); virtual;
    procedure PerformVerb(Verb: Integer); virtual;
    procedure PutPropInBag(const PropName: WideString; DispatchID: Integer;
      PropBag: IPropertyBag); virtual;
    procedure SaveToStream(const Stream: IStream); virtual;
    procedure WndProc(var Message: TMessage); virtual;
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
      implements IConnectionPointContainer;
  public
    destructor Destroy; override;
    procedure Initialize; override;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
    procedure PropChanged(const PropertyName: WideString); overload;
    procedure PropChanged(DispID: TDispID); overload;
    function PropRequestEdit(const PropertyName: WideString): Boolean; overload;
    function PropRequestEdit(DispID: TDispID): Boolean; overload;
    property ClientSite: IOleClientSite read FOleClientSite;
    property InPlaceSite: IOleInPlaceSite read FOleInPlaceSite;
    property Control: TWinControl read FControl;
  end;
  {$EXTERNALSYM TActiveXControl}

  TActiveXControlClass = class of TActiveXControl;
  {$EXTERNALSYM TActiveXControlClass}

  TActiveXControlFactory = class(TAutoObjectFactory)
  private
    FWinControlClass: TWinControlClass;
    FMiscStatus: Integer;
    FToolboxBitmapID: Integer;
    FVerbs: TStringList;
    FLicFileStrings: TStringList;
    FLicenseFileRead: Boolean;
  protected
    function GetLicenseFileName: string; virtual;
    function HasMachineLicense: Boolean; override;
  public
    constructor Create(ComServer: TComServerObject;
      ActiveXControlClass: TActiveXControlClass;
      WinControlClass: TWinControlClass; const ClassID: TGUID;
      ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer;
      ThreadingModel: TThreadingModel = tmSingle);
    destructor Destroy; override;
    procedure AddVerb(Verb: Integer; const VerbName: string);
    procedure UpdateRegistry(Register: Boolean); override;