home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 1997 August / VPR9708A.ISO / D3TRIAL / INSTALL / DATA.Z / AXCTRLS.INT < prev    next >
Text File  |  1997-03-20  |  23KB  |  585 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Delphi Visual Component Library                 }
  4. {       ActiveX Controls Unit                           }
  5. {                                                       }
  6. {       Copyright (c) 1997 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit AxCtrls;
  11.  
  12. interface
  13.  
  14. uses
  15.   Windows, Messages, ActiveX, SysUtils, ComObj, Classes, Graphics,
  16.   Controls, Forms, Consts, ExtCtrls, StdVcl;
  17.  
  18. const
  19.   { Delphi property page CLSIDs }
  20.   Class_DColorPropPage: TGUID = '{5CFF5D59-5946-11D0-BDEF-00A024D1875C}';
  21.   Class_DFontPropPage: TGUID = '{5CFF5D5B-5946-11D0-BDEF-00A024D1875C}';
  22.   Class_DPicturePropPage: TGUID = '{5CFF5D5A-5946-11D0-BDEF-00A024D1875C}';
  23.   Class_DStringPropPage: TGUID = '{F42D677E-754B-11D0-BDFB-00A024D1875C}';
  24.  
  25. type
  26.   TOleStream = class(TStream)
  27.   public
  28.     constructor Create(const Stream: IStream);
  29.     function Read(var Buffer; Count: Longint): Longint; override;
  30.     function Write(const Buffer; Count: Longint): Longint; override;
  31.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  32.   end;
  33.  
  34.   TAggregatedObject = class
  35.   protected
  36.     { IUnknown }
  37.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  38.     function _AddRef: Integer; stdcall;
  39.     function _Release: Integer; stdcall;
  40.   public
  41.     constructor Create(const Controller: IUnknown);
  42.     property Controller: IUnknown;
  43.   end;
  44.  
  45.   TContainedObject = class(TAggregatedObject, IUnknown)
  46.   protected
  47.     { IUnknown }
  48.     function QueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
  49.   end;
  50.  
  51.   TConnectionPoints = class;
  52.  
  53.   TConnectEvent = procedure (const Sink: IUnknown; Connecting: Boolean) of object;
  54.   TConnectionKind = (ckSingle, ckMulti);
  55.  
  56.   TConnectionPoint = class(TContainedObject, IConnectionPoint)
  57.   protected
  58.     { IConnectionPoint }
  59.     function GetConnectionInterface(out iid: TIID): HResult; stdcall;
  60.     function GetConnectionPointContainer(
  61.       out cpc: IConnectionPointContainer): HResult; stdcall;
  62.     function Advise(const unkSink: IUnknown; out dwCookie: Longint): HResult; stdcall;
  63.     function Unadvise(dwCookie: Longint): HResult; stdcall;
  64.     function EnumConnections(out enum: IEnumConnections): HResult; stdcall;
  65.   public
  66.     constructor Create(Container: TConnectionPoints;
  67.       const IID: TGUID; Kind: TConnectionKind; OnConnect: TConnectEvent);
  68.     destructor Destroy; override;
  69.   end;
  70.  
  71.   TConnectionPoints = class(TAggregatedObject,
  72.     IConnectionPointContainer)
  73.   protected
  74.     { IConnectionPointContainer }
  75.     function EnumConnectionPoints(
  76.       out enum: IEnumConnectionPoints): HResult; stdcall;
  77.     function FindConnectionPoint(const iid: TIID;
  78.       out cp: IConnectionPoint): HResult; stdcall;
  79.   public
  80.     constructor Create(const Controller: IUnknown);
  81.     destructor Destroy; override;
  82.     function CreateConnectionPoint(const IID: TGUID; Kind: TConnectionKind;
  83.       OnConnect: TConnectEvent): TConnectionPoint;
  84.   end;
  85.  
  86.   TDefinePropertyPage = procedure(const GUID: TGUID) of object;
  87.  
  88.   TActiveXControlFactory = class;
  89.  
  90.   IAmbientDispatch = dispinterface
  91.     ['{00020400-0000-0000-C000-000000000046}']
  92.     property BackColor: Integer dispid DISPID_AMBIENT_BACKCOLOR;
  93.     property DisplayName: WideString dispid DISPID_AMBIENT_DISPLAYNAME;
  94.     property Font: IFontDisp dispid DISPID_AMBIENT_FONT;
  95.     property ForeColor: Integer dispid DISPID_AMBIENT_FORECOLOR;
  96.     property LocaleID: Integer dispid DISPID_AMBIENT_LOCALEID;
  97.     property MessageReflect: WordBool dispid DISPID_AMBIENT_MESSAGEREFLECT;
  98.     property ScaleUnits: WideString dispid DISPID_AMBIENT_SCALEUNITS;
  99.     property TextAlign: Smallint dispid DISPID_AMBIENT_TEXTALIGN;
  100.     property UserMode: WordBool dispid DISPID_AMBIENT_USERMODE;
  101.     property UIDead: WordBool dispid DISPID_AMBIENT_UIDEAD;
  102.     property ShowGrabHandles: WordBool dispid DISPID_AMBIENT_SHOWGRABHANDLES;
  103.     property ShowHatching: WordBool dispid DISPID_AMBIENT_SHOWHATCHING;
  104.     property DisplayAsDefault: WordBool dispid DISPID_AMBIENT_DISPLAYASDEFAULT;
  105.     property SupportsMnemonics: WordBool dispid DISPID_AMBIENT_SUPPORTSMNEMONICS;
  106.     property AutoClip: WordBool dispid DISPID_AMBIENT_AUTOCLIP;
  107.   end;
  108.  
  109.   TActiveXControl = class(TAutoObject,
  110.     IPersistStreamInit,
  111.     IPersistStorage,
  112.     IOleObject,
  113.     IOleControl,
  114.     IOleInPlaceObject,
  115.     IOleInPlaceActiveObject,
  116.     IViewObject,
  117.     IViewObject2,
  118.     IPerPropertyBrowsing,
  119.     ISpecifyPropertyPages,
  120.     ISimpleFrameSite)
  121.   protected
  122.     { Renamed methods }
  123.     function IPersistStreamInit.Load = PersistStreamLoad;
  124.     function IPersistStreamInit.Save = PersistStreamSave;
  125.     function IPersistStorage.InitNew = PersistStorageInitNew;
  126.     function IPersistStorage.Load = PersistStorageLoad;
  127.     function IPersistStorage.Save = PersistStorageSave;
  128.     function IViewObject2.GetExtent = ViewObjectGetExtent;
  129.     { IPersist }
  130.     function GetClassID(out classID: TCLSID): HResult; stdcall;
  131.     { IPersistStreamInit }
  132.     function IsDirty: HResult; stdcall;
  133.     function PersistStreamLoad(const stm: IStream): HResult; stdcall;
  134.     function PersistStreamSave(const stm: IStream;
  135.       fClearDirty: BOOL): HResult; stdcall;
  136.     function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
  137.     function InitNew: HResult; stdcall;
  138.     { IPersistStorage }
  139.     function PersistStorageInitNew(const stg: IStorage): HResult; stdcall;
  140.     function PersistStorageLoad(const stg: IStorage): HResult; stdcall;
  141.     function PersistStorageSave(const stgSave: IStorage;
  142.       fSameAsLoad: BOOL): HResult; stdcall;
  143.     function SaveCompleted(const stgNew: IStorage): HResult; stdcall;
  144.     function HandsOffStorage: HResult; stdcall;
  145.     { IOleObject }
  146.     function SetClientSite(const clientSite: IOleClientSite): HResult;
  147.       stdcall;
  148.     function GetClientSite(out clientSite: IOleClientSite): HResult;
  149.       stdcall;
  150.     function SetHostNames(szContainerApp: POleStr;
  151.       szContainerObj: POleStr): HResult; stdcall;
  152.     function Close(dwSaveOption: Longint): HResult; stdcall;
  153.     function SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
  154.       stdcall;
  155.     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  156.       out mk: IMoniker): HResult; stdcall;
  157.     function InitFromData(const dataObject: IDataObject; fCreation: BOOL;
  158.       dwReserved: Longint): HResult; stdcall;
  159.     function GetClipboardData(dwReserved: Longint;
  160.       out dataObject: IDataObject): HResult; stdcall;
  161.     function DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
  162.       lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
  163.       stdcall;
  164.     function EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; stdcall;
  165.     function Update: HResult; stdcall;
  166.     function IsUpToDate: HResult; stdcall;
  167.     function GetUserClassID(out clsid: TCLSID): HResult; stdcall;
  168.     function GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
  169.       stdcall;
  170.     function SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
  171.       stdcall;
  172.     function GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
  173.       stdcall;
  174.     function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
  175.       stdcall;
  176.     function Unadvise(dwConnection: Longint): HResult; stdcall;
  177.     function EnumAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  178.     function GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
  179.       stdcall;
  180.     function SetColorScheme(const logpal: TLogPalette): HResult; stdcall;
  181.     { IOleControl }
  182.     function GetControlInfo(var ci: TControlInfo): HResult; stdcall;
  183.     function OnMnemonic(msg: PMsg): HResult; stdcall;
  184.     function OnAmbientPropertyChange(dispid: TDispID): HResult; stdcall;
  185.     function FreezeEvents(bFreeze: BOOL): HResult; stdcall;
  186.     { IOleWindow }
  187.     function GetWindow(out wnd: HWnd): HResult; stdcall;
  188.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  189.     { IOleInPlaceObject }
  190.     function InPlaceDeactivate: HResult; stdcall;
  191.     function UIDeactivate: HResult; stdcall;
  192.     function SetObjectRects(const rcPosRect: TRect;
  193.       const rcClipRect: TRect): HResult; stdcall;
  194.     function ReactivateAndUndo: HResult; stdcall;
  195.     { IOleInPlaceActiveObject }
  196.     function TranslateAccelerator(var msg: TMsg): HResult; stdcall;
  197.     function OnFrameWindowActivate(fActivate: BOOL): HResult; stdcall;
  198.     function OnDocWindowActivate(fActivate: BOOL): HResult; stdcall;
  199.     function ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
  200.       fFrameWindow: BOOL): HResult; stdcall;
  201.     function EnableModeless(fEnable: BOOL): HResult; stdcall;
  202.     { IViewObject }
  203.     function Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  204.       ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
  205.       prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
  206.       dwContinue: Longint): HResult; stdcall;
  207.     function GetColorSet(dwDrawAspect: Longint; lindex: Longint;
  208.       pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
  209.       out colorSet: PLogPalette): HResult; stdcall;
  210.     function Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  211.       out dwFreeze: Longint): HResult; stdcall;
  212.     function Unfreeze(dwFreeze: Longint): HResult; stdcall;
  213.     function SetAdvise(aspects: Longint; advf: Longint;
  214.       const advSink: IAdviseSink): HResult; stdcall;
  215.     function GetAdvise(pAspects: PLongint; pAdvf: PLONGINT;
  216.       out advSink: IAdviseSink): HResult; stdcall;
  217.     { IViewObject2 }
  218.     function ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
  219.       ptd: PDVTargetDevice; out size: TPoint): HResult; stdcall;
  220.     { IPerPropertyBrowsing }
  221.     function GetDisplayString(dispid: TDispID; out bstr: WideString): HResult; stdcall;
  222.     function MapPropertyToPage(dispid: TDispID; out clsid: TCLSID): HResult; stdcall;
  223.     function GetPredefinedStrings(dispid: TDispID; out caStringsOut: TCAPOleStr;
  224.       out caCookiesOut: TCALongint): HResult; stdcall;
  225.     function GetPredefinedValue(dispid: TDispID; dwCookie: Longint;
  226.       out varOut: OleVariant): HResult; stdcall;
  227.     { ISpecifyPropertyPages }
  228.     function GetPages(out pages: TCAGUID): HResult; stdcall;
  229.     { ISimpleFrameSite }
  230.     function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  231.       out res: Integer; out Cookie: Longint): HResult; stdcall;
  232.     function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  233.       out res: Integer; Cookie: Longint): HResult; stdcall;
  234.     { Standard properties }
  235.     function Get_BackColor: Integer; safecall;
  236.     function Get_Caption: WideString; safecall;
  237.     function Get_Enabled: WordBool; safecall;
  238.     function Get_Font: Font; safecall;
  239.     function Get_ForeColor: Integer; safecall;
  240.     function Get_HWnd: Integer; safecall;
  241.     function Get_TabStop: WordBool; safecall;
  242.     function Get_Text: WideString; safecall;
  243.     procedure Set_BackColor(Value: Integer); safecall;
  244.     procedure Set_Caption(const Value: WideString); safecall;
  245.     procedure Set_Enabled(Value: WordBool); safecall;
  246.     procedure Set_Font(const Value: Font); safecall;
  247.     procedure Set_ForeColor(Value: Integer); safecall;
  248.     procedure Set_TabStop(Value: WordBool); safecall;
  249.     procedure Set_Text(const Value: WideString); safecall;
  250.     { Standard event handlers }
  251.     procedure StdClickEvent(Sender: TObject);
  252.     procedure StdDblClickEvent(Sender: TObject);
  253.     procedure StdKeyDownEvent(Sender: TObject; var Key: Word;
  254.       Shift: TShiftState);
  255.     procedure StdKeyPressEvent(Sender: TObject; var Key: Char);
  256.     procedure StdKeyUpEvent(Sender: TObject; var Key: Word;
  257.       Shift: TShiftState);
  258.     procedure StdMouseDownEvent(Sender: TObject; Button: TMouseButton;
  259.       Shift: TShiftState; X, Y: Integer);
  260.     procedure StdMouseMoveEvent(Sender: TObject; Shift: TShiftState;
  261.       X, Y: Integer);
  262.     procedure StdMouseUpEvent(Sender: TObject; Button: TMouseButton;
  263.       Shift: TShiftState; X, Y: Integer);
  264.     { Helper methods }
  265.     function InPlaceActivate(ActivateUI: Boolean): HResult;
  266.     procedure ShowPropertyDialog;
  267.     { Overrideable methods }
  268.     procedure DefinePropertyPages(
  269.       DefinePropertyPage: TDefinePropertyPage); virtual;
  270.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  271.     function GetPropertyString(DispID: Integer;
  272.       var S: string): Boolean; virtual;
  273.     function GetPropertyStrings(DispID: Integer;
  274.       Strings: TStrings): Boolean; virtual;
  275.     procedure GetPropertyValue(DispID, Cookie: Integer;
  276.       var Value: OleVariant); virtual;
  277.     procedure InitializeControl; virtual;
  278.     procedure LoadFromStream(const Stream: IStream); virtual;
  279.     procedure PerformVerb(Verb: Integer); virtual;
  280.     procedure SaveToStream(const Stream: IStream); virtual;
  281.     procedure WndProc(var Message: TMessage); virtual;
  282.   public
  283.     destructor Destroy; override;
  284.     procedure Initialize; override;
  285.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; override;
  286.     function PropRequestEdit(const PropertyName: WideString): Boolean;
  287.     procedure PropChanged(const PropertyName: WideString);
  288.     property Control: TWinControl;
  289.   end;
  290.  
  291.   TActiveXControlClass = class of TActiveXControl;
  292.  
  293.   TActiveXControlFactory = class(TAutoObjectFactory)
  294.   protected
  295.     function GetLicenseFileName: string; virtual;
  296.     function HasMachineLicense: Boolean; override;
  297.   public
  298.     constructor Create(ComServer: TComServerObject;
  299.       ActiveXControlClass: TActiveXControlClass;
  300.       WinControlClass: TWinControlClass; const ClassID: TGUID;
  301.       ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer);
  302.     destructor Destroy; override;
  303.     procedure AddVerb(Verb: Integer; const VerbName: string);
  304.     procedure UpdateRegistry(Register: Boolean); override;
  305.     property EventIID: TGUID;
  306.     property EventTypeInfo: ITypeInfo;
  307.     property MiscStatus: Integer;
  308.     property ToolboxBitmapID: Integer;
  309.     property WinControlClass: TWinControlClass;
  310.   end;
  311.  
  312.   { ActiveFormControl }
  313.  
  314.   TActiveFormControl = class(TActiveXControl, IVCLComObject)
  315.   protected
  316.     procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
  317.     procedure EventSinkChanged(const EventSink: IUnknown); override;
  318.   public
  319.     procedure FreeOnRelease;
  320.     procedure InitializeControl; override;
  321.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  322.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  323.       override;
  324.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; override;
  325.   end;
  326.  
  327.   { ActiveForm }
  328.  
  329.   TActiveFormBorderStyle = (afbNone, afbSingle, afbSunken, afbRaised);
  330.  
  331.   TActiveForm = class(TCustomForm)
  332.   protected
  333.     procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); virtual;
  334.     procedure CreateParams(var Params: TCreateParams); override;
  335.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  336.     procedure Initialize; virtual;
  337.   public
  338.     constructor Create(AOwner: TComponent); override;
  339.     function WantChildKey(Child: TControl; var Message: TMessage): Boolean; override;
  340.   published
  341.     property ActiveControl;
  342.     property AutoScroll;
  343.     property AxBorderStyle: TActiveFormBorderStyle default afbSingle;
  344.     property Caption stored True;
  345.     property Color;
  346.     property Font;
  347.     property Height stored True;
  348.     property HorzScrollBar;
  349.     property KeyPreview;
  350.     property PixelsPerInch;
  351.     property PopupMenu;
  352.     property PrintScale;
  353.     property Scaled;
  354.     property ShowHint;
  355.     property VertScrollBar;
  356.     property Width stored True;
  357.     property OnActivate;
  358.     property OnClick;
  359.     property OnCreate;
  360.     property OnDblClick;
  361.     property OnDestroy;
  362.     property OnDeactivate;
  363.     property OnDragDrop;
  364.     property OnDragOver;
  365.     property OnKeyDown;
  366.     property OnKeyPress;
  367.     property OnKeyUp;
  368.     property OnMouseDown;
  369.     property OnMouseMove;
  370.     property OnMouseUp;
  371.     property OnPaint;
  372.   end;
  373.  
  374.   TActiveFormClass = class of TActiveForm;
  375.  
  376.   { ActiveFormFactory }
  377.  
  378.   TActiveFormFactory = class(TActiveXControlFactory)
  379.   public
  380.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; override;
  381.   end;
  382.  
  383.   { Property Page support }
  384.  
  385.   TActiveXPropertyPage = class;
  386.  
  387.   TPropertyPage = class(TCustomForm)
  388.   public
  389.     procedure Modified;
  390.     procedure UpdateObject; virtual;
  391.     procedure UpdatePropertyPage; virtual;
  392.     property OleObject: Variant;
  393.     procedure EnumCtlProps(PropType: TGUID; PropNames: TStrings);
  394.   published
  395.     property ActiveControl;
  396.     property AutoScroll;
  397.     property Caption;
  398.     property ClientHeight;
  399.     property ClientWidth;
  400.     property Ctl3D;
  401.     property Color;
  402.     property Enabled;
  403.     property Font;
  404.     property Height;
  405.     property HorzScrollBar;
  406.     property KeyPreview;
  407.     property PixelsPerInch;
  408.     property ParentFont;
  409.     property PopupMenu;
  410.     property PrintScale;
  411.     property Scaled;
  412.     property ShowHint;
  413.     property VertScrollBar;
  414.     property Visible;
  415.     property Width;
  416.     property OnActivate;
  417.     property OnClick;
  418.     property OnClose;
  419.     property OnCreate;
  420.     property OnDblClick;
  421.     property OnDestroy;
  422.     property OnDeactivate;
  423.     property OnDragDrop;
  424.     property OnDragOver;
  425.     property OnHide;
  426.     property OnKeyDown;
  427.     property OnKeyPress;
  428.     property OnKeyUp;
  429.     property OnMouseDown;
  430.     property OnMouseMove;
  431.     property OnMouseUp;
  432.     property OnPaint;
  433.     property OnResize;
  434.     property OnShow;
  435.   end;
  436.  
  437.   TPropertyPageClass = class of TPropertyPage;
  438.  
  439.   TActiveXPropertyPage = class(TComObject,
  440.     IPropertyPage,
  441.     IPropertyPage2)
  442.   protected
  443.     { IPropertyPage }
  444.     function SetPageSite(const pageSite: IPropertyPageSite): HResult; stdcall;
  445.     function Activate(hwndParent: HWnd; const rc: TRect; bModal: BOOL): HResult;
  446.       stdcall;
  447.     function Deactivate: HResult; stdcall;
  448.     function GetPageInfo(out pageInfo: TPropPageInfo): HResult; stdcall;
  449.     function SetObjects(cObjects: Longint; pUnkList: PUnknownList): HResult; stdcall;
  450.     function Show(nCmdShow: Integer): HResult; stdcall;
  451.     function Move(const rect: TRect): HResult; stdcall;
  452.     function IsPageDirty: HResult; stdcall;
  453.     function Apply: HResult; stdcall;
  454.     function Help(pszHelpDir: POleStr): HResult; stdcall;
  455.     function TranslateAccelerator(msg: PMsg): HResult; stdcall;
  456.     { IPropertyPage2 }
  457.     function EditProperty(dispid: TDispID): HResult; stdcall;
  458.   public
  459.     destructor Destroy; override;
  460.     procedure Initialize; override;
  461.   end;
  462.  
  463.   TActiveXPropertyPageFactory = class(TComObjectFactory)
  464.   protected
  465.     function CreateComObject(const Controller: IUnknown): TComObject; override;
  466.   public
  467.     constructor Create(ComServer: TComServerObject;
  468.       PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
  469.   end;
  470.  
  471.   { Type adapter support }
  472.  
  473.   TCustomAdapter = class(TInterfacedObject)
  474.   protected
  475.     Updating: Boolean;
  476.     procedure Changed; virtual;
  477.     procedure ConnectOleObject(OleObject: IUnknown);
  478.     procedure ReleaseOleObject;
  479.     procedure Update; virtual; abstract;
  480.   public
  481.     constructor Create;
  482.     destructor Destroy; override;
  483.   end;
  484.  
  485.   TAdapterNotifier = class(TInterfacedObject,
  486.     IPropertyNotifySink)
  487.   protected
  488.     { IPropertyNotifySink }
  489.     function OnChanged(dispid: TDispID): HResult; stdcall;
  490.     function OnRequestEdit(dispid: TDispID): HResult; stdcall;
  491.   public
  492.     constructor Create(Adapter: TCustomAdapter);
  493.   end;
  494.  
  495.   IFontAccess = interface
  496.     ['{CBA55CA0-0E57-11D0-BD2F-0020AF0E5B81}']
  497.     procedure GetOleFont(var OleFont: IFontDisp);
  498.     procedure SetOleFont(const OleFont: IFontDisp);
  499.   end;
  500.  
  501.   TFontAdapter = class(TCustomAdapter,
  502.     IChangeNotifier,
  503.     IFontAccess)
  504.   protected
  505.     { IFontAccess }
  506.     procedure GetOleFont(var OleFont: IFontDisp);
  507.     procedure SetOleFont(const OleFont: IFontDisp);
  508.     procedure Changed; override;
  509.     procedure Update; override;
  510.   public
  511.     constructor Create(Font: TFont);
  512.   end;
  513.  
  514.   IPictureAccess = interface
  515.     ['{795D4D31-43D7-11D0-9E92-0020AF3D82DA}']
  516.     procedure GetOlePicture(var OlePicture: IPictureDisp);
  517.     procedure SetOlePicture(const OlePicture: IPictureDisp);
  518.   end;
  519.  
  520.   TPictureAdapter = class(TCustomAdapter,
  521.     IChangeNotifier,
  522.     IPictureAccess)
  523.   protected
  524.     { IPictureAccess }
  525.     procedure GetOlePicture(var OlePicture: IPictureDisp);
  526.     procedure SetOlePicture(const OlePicture: IPictureDisp);
  527.     procedure Update; override;
  528.   public
  529.     constructor Create(Picture: TPicture);
  530.   end;
  531.  
  532.   TOleGraphic = class(TGraphic)
  533.   protected
  534.     procedure Changed(Sender: TObject); override;
  535.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  536.     function GetEmpty: Boolean; override;
  537.     function GetHeight: Integer; override;
  538.     function GetPalette: HPALETTE; override;
  539.     function GetTransparent: Boolean; override;
  540.     function GetWidth: Integer; override;
  541.     procedure SetHeight(Value: Integer); override;
  542.     procedure SetPalette(Value: HPALETTE); override;
  543.     procedure SetWidth(Value: Integer); override;
  544.   public
  545.     procedure Assign(Source: TPersistent); override;
  546.     procedure LoadFromFile(const Filename: string); override;
  547.     procedure LoadFromStream(Stream: TStream); override;
  548.     procedure SaveToStream(Stream: TStream); override;
  549.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  550.       APalette: HPALETTE); override;
  551.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  552.       var APalette: HPALETTE); override;
  553.     property MMHeight: Integer;      // in .01 mm units
  554.     property MMWidth: Integer;
  555.     property Picture: IPicture;
  556.   end;
  557.  
  558.   TStringsAdapter = class(TAutoIntfObject, IStrings, IStringsAdapter)
  559.   protected
  560.     { IStringsAdapter }
  561.     procedure ReferenceStrings(S: TStrings);
  562.     procedure ReleaseStrings;
  563.     { IStrings }
  564.     function Get_ControlDefault(Index: Integer): OleVariant; safecall;
  565.     procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall;
  566.     function Count: Integer; safecall;
  567.     function Get_Item(Index: Integer): OleVariant; safecall;
  568.     procedure Set_Item(Index: Integer; Value: OleVariant); safecall;
  569.     procedure Remove(Index: Integer); safecall;
  570.     procedure Clear; safecall;
  571.     function Add(Item: OleVariant): Integer; safecall;
  572.     function _NewEnum: IUnknown; safecall;
  573.   public
  574.     constructor Create(Strings: TStrings);
  575.   end;
  576.  
  577. procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
  578. procedure SetOleFont(Font: TFont; const OleFont: IFontDisp);
  579. procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
  580. procedure SetOlePicture(Picture: TPicture; const OlePicture: IPictureDisp);
  581. procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
  582. procedure SetOleStrings(Strings: TStrings; const OleStrings: IStrings);
  583.  
  584. implementation
  585.