{*******************************************************}
|
{ }
|
{ CodeGear Delphi Visual Component Library }
|
{ }
|
{ Copyright (c) 1995-2008 CodeGear }
|
{ }
|
{*******************************************************}
|
|
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}
|
// IConnectionPointContainer
|
TConnectionPoints = class
|
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;
|
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_KEYUP;
|
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;
|
ParkingName : String;
|
begin
|
Result := xParkingWindow;
|
//if Result <> 0 then Exit;
|
|
// fix Dax error : accessviolation (win2k, win xp)
|
ParkingName := 'DAXParkingWindow_' + Format('%p', [@ParkingWindowProc]);
|
|
FillChar(TempClass, sizeof(TempClass), 0);
|
if not GetClassInfo(HInstance, PChar(ParkingName), TempClass) then // fix Dax error : accessviolation (win2k, win xp)
|
begin
|
TempClass.hInstance := HInstance;
|
TempClass.lpfnWndProc := @ParkingWindowProc;
|
TempClass.lpszClassName := PChar(ParkingName); // fix Dax error : accessviolation (win2k, win xp)
|
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 ParkingWindow: HWND;
|
var
|
TempClass: TWndClass;
|
begin
|
Result := xParkingWindow;
|
if Result <> 0 then Exit;
|
|
if GetClassInfo(HInstance, 'DAXParkingWindow', TempClass) and
|
(TempClass.lpfnWndProc <> @ParkingWindowProc) and
|
not Windows.UnregisterClass('DAXParkingWindow', HInstance) then
|
RaiseLastOSError;
|
|
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;
|
if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
|
Result := EOleSysError(E).ErrorCode else
|
Result := E_UNEXPECTED;
|
end;
|
|
procedure FreeObjects(List: TList);
|
var
|
I: Integer;
|
begin
|
for I := List.Count - 1 downto 0 do TObject(List[I]).Free;
|
end;
|
|
procedure FreeObjectList(List: TList);
|
begin
|
if List <> nil then
|
begin
|
FreeObjects(List);
|
List.Free;
|
end;
|
end;
|
|
function CoAllocMem(Size: Integer): Pointer;
|
begin
|
Result := CoTaskMemAlloc(Size);
|
if Result = nil then OleError(E_OUTOFMEMORY);
|
FillChar(Result^, Size, 0);
|
end;
|
|
procedure CoFreeMem(P: Pointer);
|
begin
|
if P <> nil then CoTaskMemFree(P);
|
end;
|
|
function CoAllocString(const S: string): POleStr;
|
var
|
W: WideString;
|
Size: Integer;
|
begin
|
W := S;
|
Size := (Length(W) + 1) * 2;
|
Result := CoAllocMem(Size);
|
Move(PWideChar(W)^, Result^, Size);
|
end;
|
|
{ Fill list with properties of a given IDispatch }
|
|
procedure EnumDispatchProperties(Dispatch: IDispatch; PropType: TGUID;
|
VTCode: Integer; PropList: TStrings);
|
const
|
INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
|
var
|
I: Integer;
|
TypeInfo: ITypeInfo;
|
TypeAttr: PTypeAttr;
|
FuncDesc: PFuncDesc;
|
VarDesc: PVarDesc;
|
|
procedure SaveName(Id: Integer);
|
var
|
Name: WideString;
|
begin
|
OleCheck(TypeInfo.GetDocumentation(Id, @Name, nil, nil, nil));
|
if PropList.IndexOfObject(TObject(Id)) = -1 then
|
PropList.AddObject(Name, TObject(Id));
|
end;
|
|
function IsPropType(const TypeInfo: ITypeInfo; TypeDesc: PTypeDesc): Boolean;
|
var
|
RefInfo: ITypeInfo;
|
RefAttr: PTypeAttr;
|
IsNullGuid: Boolean;
|
begin
|
IsNullGuid := IsEqualGuid(PropType, GUID_NULL);
|
Result := IsNullGuid and (VTCode = VT_EMPTY);
|
if Result then Exit;
|
case TypeDesc.vt of
|
VT_PTR: Result := IsPropType(TypeInfo, TypeDesc.ptdesc);
|
VT_USERDEFINED:
|
begin
|
OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo));
|
OleCheck(RefInfo.GetTypeAttr(RefAttr));
|
try
|
Result := IsEqualGUID(RefAttr.guid, PropType);
|
if not Result and (RefAttr.typekind = TKIND_ALIAS) then
|
Result := IsPropType(RefInfo, @RefAttr.tdescAlias);
|
finally
|
RefInfo.ReleaseTypeAttr(RefAttr);
|
end;
|
end;
|
else
|
Result := IsNullGuid and (TypeDesc.vt = VTCode);
|
end;
|
end;
|
|
function HasMember(const TypeInfo: ITypeInfo; Cnt, MemID, InvKind: Integer): Boolean;
|
var
|
I: Integer;
|
FuncDesc: PFuncDesc;
|
begin
|
for I := 0 to Cnt - 1 do
|
begin
|
OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
|
try
|
if (FuncDesc.memid = MemID) and (FuncDesc.invkind and InvKind <> 0) then
|
begin
|
Result := True;
|
Exit;
|
end;
|
finally
|
TypeInfo.ReleaseFuncDesc(FuncDesc);
|
end;
|
end;
|
Result := False;
|
end;
|
|
begin
|
OleCheck(Dispatch.GetTypeInfo(0,0,TypeInfo));
|
if TypeInfo = nil then Exit;
|
OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
|
try
|
for I := 0 to TypeAttr.cVars - 1 do
|
begin
|
OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
|
try
|
if (VarDesc.wVarFlags and VARFLAG_FREADONLY <> 0) and
|
IsPropType(TypeInfo, @VarDesc.elemdescVar.tdesc) then
|
SaveName(VarDesc.memid);
|
finally
|
TypeInfo.ReleaseVarDesc(VarDesc);
|
end;
|
end;
|
for I := 0 to TypeAttr.cFuncs - 1 do
|
begin
|
OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
|
try
|
if ((FuncDesc.invkind = INVOKE_PROPERTYGET) and (FuncDesc.cParams < 1) and
|
HasMember(TypeInfo, TypeAttr.cFuncs, FuncDesc.memid, INVOKE_PROPERTYSET) and
|
IsPropType(TypeInfo, @FuncDesc.elemdescFunc.tdesc)) or
|
((FuncDesc.invkind and INVOKE_PROPERTYSET <> 0) and (FuncDesc.cParams < 2) and
|
HasMember(TypeInfo, TypeAttr.cFuncs, FuncDesc.memid, INVOKE_PROPERTYGET) and
|
IsPropType(TypeInfo,
|
@FuncDesc.lprgelemdescParam[FuncDesc.cParams - 1].tdesc)) then
|
SaveName(FuncDesc.memid);
|
finally
|
TypeInfo.ReleaseFuncDesc(FuncDesc);
|
end;
|
end;
|
finally
|
TypeInfo.ReleaseTypeAttr(TypeAttr);
|
end;
|
end;
|
|
{ Font and Picture support }
|
|
function GetFontAccess(Font: TFont): IFontAccess;
|
begin
|
if Font.FontAdapter = nil then
|
Font.FontAdapter := TFontAdapter.Create(Font);
|
Result := Font.FontAdapter as IFontAccess;
|
end;
|
|
function GetPictureAccess(Picture: TPicture): IPictureAccess;
|
begin
|
if Picture.PictureAdapter = nil then
|
Picture.PictureAdapter := TPictureAdapter.Create(Picture);
|
Result := Picture.PictureAdapter as IPictureAccess;
|
end;
|
|
procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
|
begin
|
GetFontAccess(Font).GetOleFont(OleFont);
|
end;
|
|
procedure SetOleFont(Font: TFont; OleFont: IFontDisp);
|
begin
|
GetFontAccess(Font).SetOleFont(OleFont);
|
end;
|
|
procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
|
begin
|
GetPictureAccess(Picture).GetOlePicture(OlePicture);
|
end;
|
|
procedure SetOlePicture(Picture: TPicture; OlePicture: IPictureDisp);
|
begin
|
GetPictureAccess(Picture).SetOlePicture(OlePicture);
|
end;
|
|
function GetKeyModifiers: Integer;
|
begin
|
Result := 0;
|
if GetKeyState(VK_SHIFT) < 0 then Result := 1;
|
if GetKeyState(VK_CONTROL) < 0 then Result := Result or 2;
|
if GetKeyState(VK_MENU) < 0 then Result := Result or 4;
|
end;
|
|
function GetEventShift(Shift: TShiftState): Integer;
|
const
|
ShiftMap: array[0..7] of Byte = (0, 1, 4, 5, 2, 3, 6, 7);
|
begin
|
Result := ShiftMap[Byte(Shift) and 7];
|
end;
|
|
function GetEventButton(Button: TMouseButton): Integer;
|
begin
|
Result := 1 shl Ord(Button);
|
end;
|
|
{ TOleStream }
|
|
constructor TOleStream.Create(const Stream: IStream);
|
begin
|
FStream := Stream;
|
end;
|
|
function TOleStream.Read(var Buffer; Count: Longint): Longint;
|
begin
|
OleCheck(FStream.Read(@Buffer, Count, @Result));
|
end;
|
|
function TOleStream.Seek(Offset: Longint; Origin: Word): Longint;
|
var
|
Pos: Largeint;
|
begin
|
OleCheck(FStream.Seek(Offset, Origin, Pos));
|
Result := Longint(Pos);
|
end;
|
|
function TOleStream.Write(const Buffer; Count: Longint): Longint;
|
begin
|
OleCheck(FStream.Write(@Buffer, Count, @Result));
|
end;
|
|
function TOleStream.GetIStream: IStream;
|
begin
|
Result := FStream;
|
end;
|
|
{ TEnumConnections }
|
|
type
|
TEnumConnections = class(TInterfacedObject, IEnumConnections)
|
private
|
FConnectionPoint: TConnectionPoint;
|
FController: IUnknown;
|
FIndex: Integer;
|
FCount: Integer;
|
protected
|
{ IEnumConnections }
|
function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
|
function Skip(celt: Longint): HResult; stdcall;
|
function Reset: HResult; stdcall;
|
function Clone(out enumconn: IEnumConnections): HResult; stdcall;
|
public
|
constructor Create(ConnectionPoint: TConnectionPoint; Index: Integer);
|
end;
|
|
constructor TEnumConnections.Create(ConnectionPoint: TConnectionPoint;
|
Index: Integer);
|
begin
|
inherited Create;
|
FConnectionPoint := ConnectionPoint;
|
// keep ConnectionPoint's controller alive as long as we're in use
|
FController := FConnectionPoint.Controller;
|
FIndex := Index;
|
FCount := ConnectionPoint.FSinkList.Count;
|
end;
|
|
{ TEnumConnections.IEnumConnections }
|
|
function TEnumConnections.Next(celt: Longint; out elt;
|
pceltFetched: PLongint): HResult;
|
type
|
TConnectDatas = array[0..1023] of TConnectData;
|
var
|
I: Integer;
|
P: Pointer;
|
begin
|
I := 0;
|
while (I < celt) and (FIndex < FCount) do
|
begin
|
P := FConnectionPoint.FSinkList[FIndex];
|
if P <> nil then
|
begin
|
Pointer(TConnectDatas(elt)[I].pUnk) := nil;
|
TConnectDatas(elt)[I].pUnk := IUnknown(P);
|
TConnectDatas(elt)[I].dwCookie := FIndex + 1;
|
Inc(I);
|
end;
|
Inc(FIndex);
|
end;
|
if pceltFetched <> nil then pceltFetched^ := I;
|
if I = celt then Result := S_OK else Result := S_FALSE;
|
end;
|
|
function TEnumConnections.Skip(celt: Longint): HResult; stdcall;
|
begin
|
Result := S_FALSE;
|
while (celt > 0) and (FIndex < FCount) do
|
begin
|
if FConnectionPoint.FSinkList[FIndex] <> nil then Dec(celt);
|
Inc(FIndex);
|
end;
|
if celt = 0 then Result := S_OK;
|
end;
|
|
function TEnumConnections.Reset: HResult; stdcall;
|
begin
|
FIndex := 0;
|
Result := S_OK;
|
end;
|
|
function TEnumConnections.Clone(out enumconn: IEnumConnections): HResult; stdcall;
|
begin
|
try
|
enumconn := TEnumConnections.Create(FConnectionPoint, FIndex);
|
Result := S_OK;
|
except
|
Result := E_UNEXPECTED;
|
end;
|
end;
|
|
{ TConnectionPoint }
|
|
constructor TConnectionPoint.Create(Container: TConnectionPoints;
|
const IID: TGUID; Kind: TConnectionKind;
|
OnConnect: TConnectEvent);
|
begin
|
inherited Create(IUnknown(Container.FController));
|
FContainer := Container;
|
FContainer.FConnectionPoints.Add(Self);
|
FSinkList := TList.Create;
|
FIID := IID;
|
FKind := Kind;
|
FOnConnect := OnConnect;
|
end;
|
|
destructor TConnectionPoint.Destroy;
|
var
|
I: Integer;
|
begin
|
if FContainer <> nil then FContainer.FConnectionPoints.Remove(Self);
|
if FSinkList <> nil then
|
begin
|
for I := 0 to FSinkList.Count - 1 do
|
if FSinkList[I] <> nil then RemoveSink(I);
|
FSinkList.Free;
|
end;
|
inherited Destroy;
|
end;
|
|
function TConnectionPoint.AddSink(const Sink: IUnknown): Integer;
|
var
|
I: Integer;
|
begin
|
I := 0;
|
|
while I < FSinkList.Count do
|
begin
|
if FSinkList[I] = nil then
|
Break
|
else
|
Inc(I);
|
end;
|
|
if I >= FSinkList.Count then
|
FSinkList.Add(Pointer(Sink))
|
else
|
FSinkList[I] := Pointer(Sink);
|
|
Sink._AddRef;
|
Result := I;
|
end;
|
|
procedure TConnectionPoint.RemoveSink(Cookie: Longint);
|
var
|
Sink: Pointer;
|
begin
|
Sink := FSinkList[Cookie];
|
FSinkList[Cookie] := nil;
|
IUnknown(Sink)._Release;
|
end;
|
|
{ TConnectionPoint.IConnectionPoint }
|
|
function TConnectionPoint.GetConnectionInterface(out iid: TIID): HResult;
|
begin
|
iid := FIID;
|
Result := S_OK;
|
end;
|
|
function TConnectionPoint.GetConnectionPointContainer(
|
out cpc: IConnectionPointContainer): HResult;
|
begin
|
cpc := IUnknown(FContainer.FController) as IConnectionPointContainer;
|
Result := S_OK;
|
end;
|
|
function TConnectionPoint.Advise(const unkSink: IUnknown;
|
out dwCookie: Longint): HResult;
|
begin
|
if (FKind = ckSingle) and (FSinkList.Count > 0) and
|
(FSinkList[0] <> nil) then
|
begin
|
Result := CONNECT_E_CANNOTCONNECT;
|
Exit;
|
end;
|
try
|
if Assigned(FOnConnect) then FOnConnect(unkSink, True);
|
dwCookie := AddSink(unkSink) + 1;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TConnectionPoint.Unadvise(dwCookie: Longint): HResult;
|
begin
|
Dec(dwCookie);
|
if (dwCookie < 0) or (dwCookie >= FSinkList.Count) or
|
(FSinkList[dwCookie] = nil) then
|
begin
|
Result := CONNECT_E_NOCONNECTION;
|
Exit;
|
end;
|
try
|
if Assigned(FOnConnect) then
|
FOnConnect(IUnknown(FSinkList[dwCookie]), False);
|
RemoveSink(dwCookie);
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TConnectionPoint.EnumConnections(out enumconn: IEnumConnections): HResult;
|
begin
|
try
|
enumconn := TEnumConnections.Create(Self, 0);
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
{ TEnumConnectionPoints }
|
|
type
|
TEnumConnectionPoints = class(TContainedObject, IEnumConnectionPoints)
|
private
|
FContainer: TConnectionPoints;
|
FIndex: Integer;
|
protected
|
{ IEnumConnectionPoints }
|
function Next(celt: Longint; out elt;
|
pceltFetched: PLongint): HResult; stdcall;
|
function Skip(celt: Longint): HResult; stdcall;
|
function Reset: HResult; stdcall;
|
function Clone(out enumconn: IEnumConnectionPoints): HResult; stdcall;
|
public
|
constructor Create(Container: TConnectionPoints;
|
Index: Integer);
|
end;
|
|
constructor TEnumConnectionPoints.Create(Container: TConnectionPoints;
|
Index: Integer);
|
begin
|
inherited Create(IUnknown(Container.FController));
|
FContainer := Container;
|
FIndex := Index;
|
end;
|
|
{ TEnumConnectionPoints.IEnumConnectionPoints }
|
|
type
|
TPointerList = array[0..0] of Pointer;
|
|
function TEnumConnectionPoints.Next(celt: Longint; out elt;
|
pceltFetched: PLongint): HResult;
|
var
|
I: Integer;
|
P: Pointer;
|
begin
|
I := 0;
|
while (I < celt) and (FIndex < FContainer.FConnectionPoints.Count) do
|
begin
|
P := Pointer(IConnectionPoint(TConnectionPoint(
|
FContainer.FConnectionPoints[FIndex])));
|
IConnectionPoint(P)._AddRef;
|
TPointerList(elt)[I] := P;
|
Inc(I);
|
Inc(FIndex);
|
end;
|
if pceltFetched <> nil then pceltFetched^ := I;
|
if I = celt then Result := S_OK else Result := S_FALSE;
|
end;
|
|
function TEnumConnectionPoints.Skip(celt: Longint): HResult; stdcall;
|
begin
|
if FIndex + celt <= FContainer.FConnectionPoints.Count then
|
begin
|
FIndex := FIndex + celt;
|
Result := S_OK;
|
end else
|
begin
|
FIndex := FContainer.FConnectionPoints.Count;
|
Result := S_FALSE;
|
end;
|
end;
|
|
function TEnumConnectionPoints.Reset: HResult; stdcall;
|
begin
|
FIndex := 0;
|
Result := S_OK;
|
end;
|
|
function TEnumConnectionPoints.Clone(
|
out enumconn: IEnumConnectionPoints): HResult; stdcall;
|
begin
|
try
|
enumconn := TEnumConnectionPoints.Create(FContainer, FIndex);
|
Result := S_OK;
|
except
|
Result := E_UNEXPECTED;
|
end;
|
end;
|
|
{ TConnectionPoints }
|
|
constructor TConnectionPoints.Create(const AController: IUnknown);
|
begin // weak reference, don't keep the controller alive
|
FController := Pointer(AController);
|
FConnectionPoints := TList.Create;
|
end;
|
|
destructor TConnectionPoints.Destroy;
|
begin
|
FreeObjectList(FConnectionPoints);
|
inherited Destroy;
|
end;
|
|
function TConnectionPoints.CreateConnectionPoint(const IID: TGUID;
|
Kind: TConnectionKind; OnConnect: TConnectEvent): TConnectionPoint;
|
begin
|
Result := TConnectionPoint.Create(Self, IID, Kind, OnConnect);
|
end;
|
|
{ TConnectionPoints.IConnectionPointContainer }
|
|
function TConnectionPoints.EnumConnectionPoints(
|
out enumconn: IEnumConnectionPoints): HResult;
|
begin
|
try
|
enumconn := TEnumConnectionPoints.Create(Self, 0);
|
Result := S_OK;
|
except
|
Result := E_UNEXPECTED;
|
end;
|
end;
|
|
function TConnectionPoints.FindConnectionPoint(const iid: TIID;
|
out cp: IConnectionPoint): HResult;
|
var
|
I: Integer;
|
ConnectionPoint: TConnectionPoint;
|
begin
|
for I := 0 to FConnectionPoints.Count - 1 do
|
begin
|
ConnectionPoint := FConnectionPoints[I];
|
if IsEqualGUID(ConnectionPoint.FIID, iid) then
|
begin
|
cp := ConnectionPoint;
|
Result := S_OK;
|
Exit;
|
end;
|
end;
|
Result := CONNECT_E_NOCONNECTION;
|
end;
|
|
function TConnectionPoints.GetController: IUnknown;
|
begin
|
Result := IUnknown(FController);
|
end;
|
|
{ TReflectorWindow }
|
|
|
constructor TReflectorWindow.Create(ParentWindow: HWND; Control: TControl);
|
begin
|
inherited CreateParented(ParentWindow);
|
FControl := Control;
|
FInSize := True;
|
try
|
FControl.Parent := Self;
|
FControl.SetBounds(0, 0, FControl.Width, FControl.Height);
|
finally
|
FInSize := False;
|
end;
|
SetBounds(Left, Top, FControl.Width, FControl.Height);
|
end;
|
|
procedure TReflectorWindow.CreateParams(var Params: TCreateParams);
|
begin
|
inherited CreateParams(Params);
|
Params.Style := Params.Style or WS_CLIPCHILDREN;
|
end;
|
|
procedure TReflectorWindow.WMGetDlgCode(var Message: TMessage);
|
begin
|
TWinControlAccess(FControl).WndProc(Message);
|
end;
|
|
procedure TReflectorWindow.WMSetFocus(var Message: TWMSetFocus);
|
begin
|
if FControl is TWinControl then
|
Windows.SetFocus(TWinControl(FControl).Handle) else
|
inherited;
|
end;
|
|
procedure TReflectorWindow.WMSize(var Message: TWMSize);
|
begin
|
if not FInSize then
|
begin
|
FInSize := True;
|
try
|
FControl.SetBounds(0, 0, Message.Width, Message.Height);
|
SetBounds(Left, Top, FControl.Width, FControl.Height);
|
finally
|
FInSize := False;
|
end;
|
end;
|
inherited;
|
end;
|
|
{ TOleLinkStub }
|
|
type
|
TOleLinkStub = class(TInterfacedObject, IUnknown, IOleLink)
|
private
|
Controller: IUnknown;
|
public
|
constructor Create(const AController: IUnknown);
|
{ IUnknown }
|
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
{ IOleLink }
|
function SetUpdateOptions(dwUpdateOpt: Longint): HResult;
|
stdcall;
|
function GetUpdateOptions(out dwUpdateOpt: Longint): HResult; stdcall;
|
function SetSourceMoniker(const mk: IMoniker; const clsid: TCLSID): HResult;
|
stdcall;
|
function GetSourceMoniker(out mk: IMoniker): HResult; stdcall;
|
function SetSourceDisplayName(pszDisplayName: POleStr): HResult;
|
stdcall;
|
function GetSourceDisplayName(out pszDisplayName: POleStr): HResult;
|
stdcall;
|
function BindToSource(bindflags: Longint; const bc: IBindCtx): HResult;
|
stdcall;
|
function BindIfRunning: HResult; stdcall;
|
function GetBoundSource(out unk: IUnknown): HResult; stdcall;
|
function UnbindSource: HResult; stdcall;
|
function Update(const bc: IBindCtx): HResult; stdcall;
|
end;
|
|
constructor TOleLinkStub.Create(const AController: IUnknown);
|
begin
|
inherited Create;
|
Controller := AController;
|
end;
|
|
{ TOleLinkStub.IUnknown }
|
|
function TOleLinkStub.QueryInterface(const IID: TGUID; out Obj): HResult;
|
begin
|
Result := Controller.QueryInterface(IID, Obj);
|
end;
|
|
{ TOleLinkStub.IOleLink }
|
|
function TOleLinkStub.SetUpdateOptions(dwUpdateOpt: Longint): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.GetUpdateOptions(out dwUpdateOpt: Longint): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.SetSourceMoniker(const mk: IMoniker; const clsid: TCLSID): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.GetSourceMoniker(out mk: IMoniker): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.SetSourceDisplayName(pszDisplayName: POleStr): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.GetSourceDisplayName(out pszDisplayName: POleStr): HResult;
|
begin
|
pszDisplayName := nil;
|
Result := E_FAIL;
|
end;
|
|
function TOleLinkStub.BindToSource(bindflags: Longint; const bc: IBindCtx): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.BindIfRunning: HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
function TOleLinkStub.GetBoundSource(out unk: IUnknown): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.UnbindSource: HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TOleLinkStub.Update(const bc: IBindCtx): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
{ TActiveXControl }
|
|
procedure TActiveXControl.Initialize;
|
begin
|
inherited Initialize;
|
FConnectionPoints := TConnectionPoints.Create(Self);
|
FOleLinkStub := TOleLinkStub.Create(nil);
|
FOleLinkStub._AddRef;
|
FControlFactory := Factory as TActiveXControlFactory;
|
if FControlFactory.EventTypeInfo <> nil then
|
FConnectionPoints.CreateConnectionPoint(FControlFactory.EventIID,
|
ckSingle, EventConnect);
|
FPropertySinks := FConnectionPoints.CreateConnectionPoint(IPropertyNotifySink,
|
ckMulti, nil);
|
FControl := FControlFactory.WinControlClass.CreateParented(ParkingWindow);
|
if csReflector in FControl.ControlStyle then
|
FWinControl := TReflectorWindow.Create(ParkingWindow, FControl) else
|
FWinControl := FControl;
|
FControlWndProc := FControl.WindowProc;
|
FControl.WindowProc := WndProc;
|
InitializeControl;
|
end;
|
|
destructor TActiveXControl.Destroy;
|
begin
|
if Assigned(FControlWndProc) then FControl.WindowProc := FControlWndProc;
|
FControl.Free;
|
if FWinControl <> FControl then FWinControl.Free;
|
FConnectionPoints.Free;
|
FOleLinkStub := nil;
|
inherited Destroy;
|
end;
|
|
function TActiveXControl.CreateAdviseHolder: HResult;
|
begin
|
if FOleAdviseHolder = nil then
|
Result := CreateOleAdviseHolder(FOleAdviseHolder) else
|
Result := S_OK;
|
end;
|
|
procedure TActiveXControl.DefinePropertyPages(
|
DefinePropertyPage: TDefinePropertyPage);
|
begin
|
end;
|
|
function TActiveXControl.GetPropertyString(DispID: Integer;
|
var S: string): Boolean;
|
begin
|
Result := False;
|
end;
|
|
function TActiveXControl.GetPropertyStrings(DispID: Integer;
|
Strings: TStrings): Boolean;
|
begin
|
Result := False;
|
end;
|
|
procedure TActiveXControl.GetPropFromBag(const PropName: WideString;
|
DispatchID: Integer; PropBag: IPropertyBag; ErrorLog: IErrorLog);
|
var
|
PropValue: OleVariant;
|
begin
|
// Note: raise an EAbort exception here to stop properties from loading
|
if PropBag.Read(PWideChar(PropName), PropValue, ErrorLog) = S_OK then
|
ComObj.SetDispatchPropValue(Self as IDispatch, DispatchID, PropValue);
|
end;
|
|
procedure TActiveXControl.PutPropInBag(const PropName: WideString;
|
DispatchID: Integer; PropBag: IPropertyBag);
|
begin
|
PropBag.Write(PWideChar(PropName), ComObj.GetDispatchPropValue(Self as IDispatch,
|
DispatchID));
|
end;
|
|
procedure TActiveXControl.GetPropertyValue(DispID, Cookie: Integer;
|
var Value: OleVariant);
|
begin
|
end;
|
|
procedure TActiveXControl.InitializeControl;
|
begin
|
end;
|
|
function TActiveXControl.InPlaceActivate(ActivateUI: Boolean): HResult;
|
var
|
InPlaceActivateSent: Boolean;
|
ParentWindow: HWND;
|
PosRect, ClipRect: TRect;
|
FrameInfo: TOleInPlaceFrameInfo;
|
begin
|
Result := S_OK;
|
FWinControl.Visible := True;
|
InPlaceActivateSent := False;
|
if not FInPlaceActive then
|
try
|
if FOleClientSite = nil then OleError(E_FAIL);
|
OleCheck(FOleClientSite.QueryInterface(IOleInPlaceSite, FOleInPlaceSite));
|
if FOleInPlaceSite.CanInPlaceActivate <> S_OK then OleError(E_FAIL);
|
OleCheck(FOleInPlaceSite.OnInPlaceActivate);
|
InPlaceActivateSent := True;
|
OleCheck(FOleInPlaceSite.GetWindow(ParentWindow));
|
FrameInfo.cb := SizeOf(FrameInfo);
|
OleCheck(FOleInPlaceSite.GetWindowContext(FOleInPlaceFrame,
|
FOleInPlaceUIWindow, PosRect, ClipRect, FrameInfo));
|
if FOleInPlaceFrame = nil then OleError(E_FAIL);
|
with PosRect do
|
FWinControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
|
FWinControl.ParentWindow := ParentWindow;
|
FWinControl.Visible := True;
|
FInPlaceActive := True;
|
FOleClientSite.ShowObject;
|
except
|
FInPlaceActive := False;
|
FOleInPlaceUIWindow := nil;
|
FOleInPlaceFrame := nil;
|
if InPlaceActivateSent then FOleInPlaceSite.OnInPlaceDeactivate;
|
FOleInPlaceSite := nil;
|
Result := HandleException;
|
Exit;
|
end;
|
if ActivateUI and not FUIActive then
|
begin
|
FUIActive := True;
|
FOleInPlaceSite.OnUIActivate;
|
SetFocus(FWinControl.Handle);
|
FOleInPlaceFrame.SetActiveObject(Self as IOleInPlaceActiveObject, nil);
|
if FOleInPlaceUIWindow <> nil then
|
FOleInPlaceUIWindow.SetActiveObject(Self as IOleInPlaceActiveObject, nil);
|
FOleInPlaceFrame.SetBorderSpace(nil);
|
if FOleInPlaceUIWindow <> nil then
|
FOleInPlaceUIWindow.SetBorderSpace(nil);
|
end;
|
end;
|
|
procedure TActiveXControl.LoadFromStream(const Stream: IStream);
|
var
|
OleStream: TOleStream;
|
begin
|
OleStream := TOleStream.Create(Stream);
|
try
|
OleStream.ReadComponent(FControl);
|
finally
|
OleStream.Free;
|
end;
|
end;
|
|
function TActiveXControl.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
|
begin
|
if IsEqualGuid(IID, ISimpleFrameSite) and
|
((FControlFactory.MiscStatus and OLEMISC_SIMPLEFRAME) = 0) then
|
Result := E_NOINTERFACE
|
else
|
begin
|
Result := inherited ObjQueryInterface(IID, Obj);
|
if Result <> 0 then
|
if IsEqualGuid(IID, IOleLink) then
|
begin
|
// Work around for an MS Access 97 bug that requires IOleLink
|
// to be stubbed.
|
Pointer(Obj) := nil;
|
IOleLink(Obj) := TOleLinkStub.Create(Self);
|
end;
|
end;
|
end;
|
|
procedure TActiveXControl.PerformVerb(Verb: Integer);
|
begin
|
end;
|
|
function TActiveXControl.GetPropertyID(const PropertyName: WideString): Integer;
|
var
|
PName: PWideChar;
|
begin
|
PName := PWideChar(PropertyName);
|
if PropertyName = '' then
|
Result := DISPID_UNKNOWN else
|
OleCheck(GetIDsOfNames(GUID_NULL, @PName, 1, GetThreadLocale,
|
@Result));
|
end;
|
|
procedure TActiveXControl.PropChanged(const PropertyName: WideString);
|
var
|
PropID: Integer;
|
begin
|
PropID := GetPropertyID(PropertyName);
|
PropChanged(PropID);
|
end;
|
|
procedure TActiveXControl.PropChanged(DispID: TDispID);
|
var
|
Enum: IEnumConnections;
|
ConnectData: TConnectData;
|
Fetched: Longint;
|
begin
|
OleCheck(FPropertySinks.EnumConnections(Enum));
|
while Enum.Next(1, ConnectData, @Fetched) = S_OK do
|
begin
|
(ConnectData.pUnk as IPropertyNotifySink).OnChanged(DispID);
|
ConnectData.pUnk := nil;
|
end;
|
end;
|
|
function TActiveXControl.PropRequestEdit(const PropertyName: WideString): Boolean;
|
var
|
PropID: Integer;
|
begin
|
PropID := GetPropertyID(PropertyName);
|
Result := PropRequestEdit(PropID);
|
end;
|
|
function TActiveXControl.PropRequestEdit(DispID: TDispID): Boolean;
|
var
|
Enum: IEnumConnections;
|
ConnectData: TConnectData;
|
Fetched: Longint;
|
begin
|
Result := True;
|
OleCheck(FPropertySinks.EnumConnections(Enum));
|
while Enum.Next(1, ConnectData, @Fetched) = S_OK do
|
begin
|
Result := (ConnectData.pUnk as IPropertyNotifySink).OnRequestEdit(DispID) = S_OK;
|
ConnectData.pUnk := nil;
|
if not Result then Exit;
|
end;
|
end;
|
|
procedure TActiveXControl.RecreateWnd;
|
var
|
WasUIActive: Boolean;
|
PrevWnd: HWND;
|
begin
|
if FWinControl.HandleAllocated then
|
begin
|
WasUIActive := FUIActive;
|
PrevWnd := Windows.GetWindow(FWinControl.Handle, GW_HWNDPREV);
|
InPlaceDeactivate;
|
TWinControlAccess(FWinControl).DestroyHandle;
|
if InPlaceActivate(WasUIActive) = S_OK then
|
SetWindowPos(FWinControl.Handle, PrevWnd, 0, 0, 0, 0,
|
SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);
|
end;
|
end;
|
|
procedure TActiveXControl.SaveToStream(const Stream: IStream);
|
var
|
OleStream: TOleStream;
|
Writer: TWriter;
|
begin
|
OleStream := TOleStream.Create(Stream);
|
try
|
Writer := TWriter.Create(OleStream, 4096);
|
try
|
Writer.IgnoreChildren := True;
|
Writer.WriteDescendent(FControl, nil);
|
finally
|
Writer.Free;
|
end;
|
finally
|
OleStream.Free;
|
end;
|
end;
|
|
procedure TActiveXControl.ShowPropertyDialog;
|
var
|
Unknown: IUnknown;
|
Pages: TCAGUID;
|
begin
|
if (FOleControlSite <> nil) and
|
(FOleControlSite.ShowPropertyFrame = S_OK) then Exit;
|
OleCheck(GetPages(Pages));
|
try
|
if Pages.cElems > 0 then
|
begin
|
if FOleInPlaceFrame <> nil then
|
FOleInPlaceFrame.EnableModeless(False);
|
try
|
Unknown := Self;
|
OleCheck(OleCreatePropertyFrame(GetActiveWindow, 16, 16,
|
PWideChar(FAmbientDispatch.DisplayName), {+ !!}
|
1, @Unknown, Pages.cElems, Pages.pElems,
|
GetSystemDefaultLCID, 0, nil));
|
finally
|
if FOleInPlaceFrame <> nil then
|
FOleInPlaceFrame.EnableModeless(True);
|
end;
|
end;
|
finally
|
CoFreeMem(pages.pElems);
|
end;
|
end;
|
|
procedure TActiveXControl.SetInPlaceSite(const NewInPlaceSite: IOleInPlaceSite);
|
begin
|
FOleInPlaceSite := NewInPlaceSite;
|
end;
|
|
procedure TActiveXControl.StdClickEvent(Sender: TObject);
|
begin
|
if EventSink <> nil then IStdEvents(EventSink).Click;
|
end;
|
|
procedure TActiveXControl.StdDblClickEvent(Sender: TObject);
|
begin
|
if EventSink <> nil then IStdEvents(EventSink).DblClick;
|
end;
|
|
procedure TActiveXControl.StdKeyDownEvent(Sender: TObject; var Key: Word;
|
Shift: TShiftState);
|
begin
|
if EventSink <> nil then
|
IStdEvents(EventSink).KeyDown(Smallint(Key), GetEventShift(Shift));
|
end;
|
|
procedure TActiveXControl.StdKeyPressEvent(Sender: TObject; var Key: Char);
|
var
|
KeyAscii: Smallint;
|
begin
|
if EventSink <> nil then
|
begin
|
KeyAscii := Ord(Key);
|
IStdEvents(EventSink).KeyPress(KeyAscii);
|
Key := Chr(KeyAscii);
|
end;
|
end;
|
|
procedure TActiveXControl.StdKeyUpEvent(Sender: TObject; var Key: Word;
|
Shift: TShiftState);
|
begin
|
if EventSink <> nil then
|
IStdEvents(EventSink).KeyUp(Smallint(Key), GetEventShift(Shift));
|
end;
|
|
procedure TActiveXControl.StdMouseDownEvent(Sender: TObject;
|
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
begin
|
if EventSink <> nil then
|
IStdEvents(EventSink).MouseDown(GetEventButton(Button),
|
GetEventShift(Shift), X, Y);
|
end;
|
|
procedure TActiveXControl.StdMouseMoveEvent(Sender: TObject;
|
Shift: TShiftState; X, Y: Integer);
|
begin
|
if EventSink <> nil then
|
IStdEvents(EventSink).MouseMove((Byte(Shift) shr 3) and 7,
|
GetEventShift(Shift), X, Y);
|
end;
|
|
procedure TActiveXControl.StdMouseUpEvent(Sender: TObject;
|
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
begin
|
if EventSink <> nil then
|
IStdEvents(EventSink).MouseUp(GetEventButton(Button),
|
GetEventShift(Shift), X, Y);
|
end;
|
|
procedure TActiveXControl.ViewChanged;
|
begin
|
if FAdviseSink <> nil then
|
begin
|
FAdviseSink.OnViewChange(DVASPECT_CONTENT, -1);
|
if FAdviseFlags and ADVF_ONLYONCE <> 0 then FAdviseSink := nil;
|
end;
|
end;
|
|
procedure TActiveXControl.WndProc(var Message: TMessage);
|
var
|
Handle: HWnd;
|
FilterMessage: Boolean;
|
Cookie: Longint;
|
|
procedure ControlWndProc;
|
begin
|
with Message do
|
if (Msg >= OCM_BASE) and (Msg < OCM_BASE + WM_USER) then
|
Msg := Msg + (CN_BASE - OCM_BASE);
|
FControlWndProc(Message);
|
with Message do
|
if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
|
Msg := Msg - (CN_BASE - OCM_BASE);
|
end;
|
|
begin
|
with Message do
|
begin
|
Handle := TWinControlAccess(FControl).WindowHandle;
|
FilterMessage := ((Msg < CM_BASE) or (Msg >= $C000)) and
|
(FSimpleFrameSite <> nil) and FInPlaceActive;
|
if FilterMessage then
|
if FSimpleFrameSite.PreMessageFilter(Handle, Msg, WParam, LParam,
|
Integer(Result), Cookie) = S_FALSE then Exit;
|
case Msg of
|
WM_SETFOCUS, WM_KILLFOCUS:
|
begin
|
ControlWndProc;
|
if FOleControlSite <> nil then
|
FOleControlSite.OnFocus(Msg = WM_SETFOCUS);
|
end;
|
CM_VISIBLECHANGED:
|
begin
|
if FControl <> FWinControl then FWinControl.Visible := FControl.Visible;
|
if not FWinControl.Visible then UIDeactivate;
|
ControlWndProc;
|
end;
|
CM_RECREATEWND:
|
begin
|
if FInPlaceActive and (FControl = FWinControl) then
|
RecreateWnd
|
else
|
begin
|
ControlWndProc;
|
ViewChanged;
|
end;
|
end;
|
CM_INVALIDATE,
|
WM_SETTEXT:
|
begin
|
ControlWndProc;
|
if not FInPlaceActive then ViewChanged;
|
end;
|
WM_NCHITTEST:
|
begin
|
ControlWndProc;
|
if Message.Result = HTTRANSPARENT then Message.Result := HTCLIENT;
|
end;
|
WM_MOUSEACTIVATE:
|
begin
|
ControlWndProc;
|
if not FUIActive and ((Message.Result = MA_ACTIVATE) or
|
(Message.Result = MA_ACTIVATEANDEAT)) and (FAmbientDispatch <> nil)
|
and FAmbientDispatch.UserMode then
|
InPlaceActivate(True);
|
end;
|
else
|
ControlWndProc;
|
end;
|
if FilterMessage then
|
FSimpleFrameSite.PostMessageFilter(Handle, Msg, WParam, LParam,
|
Integer(Result), Cookie);
|
end;
|
end;
|
|
{ TActiveXControl standard properties }
|
|
function TActiveXControl.Get_BackColor: Integer;
|
begin
|
Result := TWinControlAccess(FControl).Color;
|
end;
|
|
function TActiveXControl.Get_Caption: WideString;
|
begin
|
Result := TWinControlAccess(FControl).Caption;
|
end;
|
|
function TActiveXControl.Get_Enabled: WordBool;
|
begin
|
Result := FControl.Enabled;
|
end;
|
|
function TActiveXControl.Get_Font: Font;
|
begin
|
GetOleFont(TWinControlAccess(FControl).Font, Result);
|
end;
|
|
function TActiveXControl.Get_ForeColor: Integer;
|
begin
|
Result := TWinControlAccess(FControl).Font.Color;
|
end;
|
|
function TActiveXControl.Get_HWnd: Integer;
|
begin
|
Result := FControl.Handle;
|
end;
|
|
function TActiveXControl.Get_TabStop: WordBool;
|
begin
|
Result := FControl.TabStop;
|
end;
|
|
function TActiveXControl.Get_Text: WideString;
|
begin
|
Result := TWinControlAccess(FControl).Text;
|
end;
|
|
procedure TActiveXControl.Set_BackColor(Value: Integer);
|
begin
|
TWinControlAccess(FControl).Color := Value;
|
end;
|
|
procedure TActiveXControl.Set_Caption(const Value: WideString);
|
begin
|
TWinControlAccess(FControl).Caption := Value;
|
end;
|
|
procedure TActiveXControl.Set_Enabled(Value: WordBool);
|
begin
|
FControl.Enabled := Value;
|
end;
|
|
procedure TActiveXControl.Set_Font(const Value: Font);
|
begin
|
SetOleFont(TWinControlAccess(FControl).Font, Value);
|
end;
|
|
procedure TActiveXControl.Set_ForeColor(Value: Integer);
|
begin
|
TWinControlAccess(FControl).Font.Color := Value;
|
end;
|
|
procedure TActiveXControl.Set_TabStop(Value: WordBool);
|
begin
|
FControl.TabStop := Value;
|
end;
|
|
procedure TActiveXControl.Set_Text(const Value: WideString);
|
begin
|
TWinControlAccess(FControl).Text := Value;
|
end;
|
|
{ TActiveXControl.IPersist }
|
|
function TActiveXControl.GetClassID(out classID: TCLSID): HResult;
|
begin
|
classID := Factory.ClassID;
|
Result := S_OK;
|
end;
|
|
{ TActiveXControl.IPersistPropertyBag }
|
|
function TActiveXControl.PersistPropBagInitNew: HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.PersistPropBagLoad(const pPropBag: IPropertyBag;
|
const pErrorLog: IErrorLog): HResult;
|
var
|
PropList: TStringList;
|
i: Integer;
|
begin
|
try
|
if pPropBag = nil then
|
begin
|
Result := E_POINTER;
|
Exit;
|
end;
|
PropList := TStringList.Create;
|
try
|
EnumDispatchProperties(Self as IDispatch, GUID_NULL, VT_EMPTY, PropList);
|
for i := 0 to PropList.Count - 1 do
|
try
|
GetPropFromBag(PropList[i], Integer(PropList.Objects[i]),
|
pPropBag, pErrorLog);
|
except
|
// Supress all exceptions except EAbort
|
if ExceptObject is EAbort then
|
begin
|
Result := E_FAIL;
|
Exit;
|
end;
|
end;
|
finally
|
PropList.Free;
|
end;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.PersistPropBagSave(const pPropBag: IPropertyBag;
|
fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult;
|
var
|
PropList: TStringList;
|
i: Integer;
|
begin
|
try
|
if pPropBag = nil then
|
begin
|
Result := E_POINTER;
|
Exit;
|
end;
|
PropList := TStringList.Create;
|
try
|
EnumDispatchProperties(Self as IDispatch, GUID_NULL, VT_EMPTY, PropList);
|
for i := 0 to PropList.Count - 1 do
|
PutPropInBag(PropList[i], Integer(PropList.Objects[i]), pPropBag);
|
finally
|
PropList.Free;
|
end;
|
if fClearDirty then FIsDirty := False;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
{ TActiveXControl.IPersistStreamInit }
|
|
function TActiveXControl.IsDirty: HResult;
|
begin
|
if FIsDirty then Result := S_OK else Result := S_FALSE;
|
end;
|
|
function TActiveXControl.PersistStreamLoad(const stm: IStream): HResult;
|
begin
|
try
|
LoadFromStream(stm);
|
FIsDirty := False;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.PersistStreamSave(const stm: IStream;
|
fClearDirty: BOOL): HResult;
|
begin
|
try
|
SaveToStream(stm);
|
if fClearDirty then FIsDirty := False;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.GetSizeMax(out cbSize: Largeint): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.InitNew: HResult;
|
begin
|
try
|
FIsDirty := False;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
{ TActiveXControl.IPersistStorage }
|
|
function TActiveXControl.PersistStorageInitNew(const stg: IStorage): HResult;
|
begin
|
Result := InitNew;
|
end;
|
|
function TActiveXControl.PersistStorageLoad(const stg: IStorage): HResult;
|
var
|
Stream: IStream;
|
begin
|
try
|
OleCheck(stg.OpenStream('CONTROLSAVESTREAM'#0, nil, STGM_READ +
|
STGM_SHARE_EXCLUSIVE, 0, Stream));
|
LoadFromStream(Stream);
|
FIsDirty := False;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.PersistStorageSave(const stgSave: IStorage;
|
fSameAsLoad: BOOL): HResult;
|
var
|
Stream: IStream;
|
begin
|
try
|
OleCheck(stgSave.CreateStream('CONTROLSAVESTREAM'#0, STGM_WRITE +
|
STGM_SHARE_EXCLUSIVE + STGM_CREATE, 0, 0, Stream));
|
SaveToStream(Stream);
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.SaveCompleted(const stgNew: IStorage): HResult;
|
begin
|
FIsDirty := False;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.HandsOffStorage: HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
{ TActiveXControl.IObjectSafety }
|
|
function TActiveXControl.GetInterfaceSafetyOptions(const IID: TIID;
|
pdwSupportedOptions, pdwEnabledOptions: PDWORD): HResult;
|
var
|
Unk: IUnknown;
|
begin
|
if (pdwSupportedOptions = nil) or (pdwEnabledOptions = nil) then
|
begin
|
Result := E_POINTER;
|
Exit;
|
end;
|
Result := QueryInterface(IID, Unk);
|
if Result = S_OK then
|
begin
|
pdwSupportedOptions^ := INTERFACESAFE_FOR_UNTRUSTED_CALLER or
|
INTERFACESAFE_FOR_UNTRUSTED_DATA;
|
pdwEnabledOptions^ := FObjectSafetyFlags and
|
(INTERFACESAFE_FOR_UNTRUSTED_CALLER or INTERFACESAFE_FOR_UNTRUSTED_DATA);
|
end
|
else begin
|
pdwSupportedOptions^ := 0;
|
pdwEnabledOptions^ := 0;
|
end;
|
end;
|
|
function TActiveXControl.SetInterfaceSafetyOptions(const IID: TIID;
|
dwOptionSetMask, dwEnabledOptions: DWORD): HResult;
|
var
|
Unk: IUnknown;
|
begin
|
Result := QueryInterface(IID, Unk);
|
if Result <> S_OK then Exit;
|
FObjectSafetyFlags := dwEnabledOptions and dwOptionSetMask;
|
end;
|
|
{ TActiveXControl.IOleObject }
|
|
function TActiveXControl.SetClientSite(const ClientSite: IOleClientSite): HResult;
|
begin
|
if ClientSite <> nil then
|
begin
|
if FOleClientSite <> nil then
|
begin
|
Result := E_FAIL;
|
Exit;
|
end;
|
FOleClientSite := ClientSite;
|
ClientSite.QueryInterface(IOleControlSite, FOleControlSite);
|
if FControlFactory.MiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
|
ClientSite.QueryInterface(ISimpleFrameSite, FSimpleFrameSite);
|
ClientSite.QueryInterface(IDispatch, FAmbientDispatch);
|
OnAmbientPropertyChange(0);
|
end else
|
begin
|
FAmbientDispatch := nil;
|
FSimpleFrameSite := nil;
|
FOleControlSite := nil;
|
FOleClientSite := nil;
|
end;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.GetClientSite(out clientSite: IOleClientSite): HResult;
|
begin
|
ClientSite := FOleClientSite;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.SetHostNames(szContainerApp: POleStr;
|
szContainerObj: POleStr): HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.Close(dwSaveOption: Longint): HResult;
|
begin
|
Application.CancelHint;
|
if (dwSaveOption <> OLECLOSE_NOSAVE) and FIsDirty and
|
(FOleClientSite <> nil) then FOleClientSite.SaveObject;
|
if (self is TActiveFormControl)
|
then if (TActiveFormControl(self).Control is TActiveForm)
|
then
|
TActiveForm(TActiveFormControl(self).Control).DoDestroy;
|
Result := InPlaceDeactivate;
|
end;
|
|
function TActiveXControl.SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
|
out mk: IMoniker): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.InitFromData(const dataObject: IDataObject; fCreation: BOOL;
|
dwReserved: Longint): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.GetClipboardData(dwReserved: Longint;
|
out dataObject: IDataObject): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
|
lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
|
begin
|
try
|
case iVerb of
|
OLEIVERB_SHOW,
|
OLEIVERB_UIACTIVATE:
|
Result := InPlaceActivate(True);
|
OLEIVERB_INPLACEACTIVATE:
|
Result := InPlaceActivate(False);
|
OLEIVERB_HIDE:
|
begin
|
FWinControl.Visible := False;
|
Result := S_OK;
|
end;
|
OLEIVERB_PRIMARY,
|
OLEIVERB_PROPERTIES:
|
begin
|
ShowPropertyDialog;
|
Result := S_OK;
|
end;
|
else
|
if FControlFactory.FVerbs.IndexOfObject(TObject(iVerb)) >= 0 then
|
begin
|
PerformVerb(iVerb);
|
Result := S_OK;
|
end else
|
Result := OLEOBJ_S_INVALIDVERB;
|
end;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult;
|
begin
|
Result := OleRegEnumVerbs(Factory.ClassID, enumOleVerb);
|
end;
|
|
function TActiveXControl.Update: HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.IsUpToDate: HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.GetUserClassID(out clsid: TCLSID): HResult;
|
begin
|
clsid := Factory.ClassID;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
|
begin
|
Result := OleRegGetUserType(Factory.ClassID, dwFormOfType, pszUserType);
|
end;
|
|
function TActiveXControl.SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
|
var
|
W, H: Integer;
|
begin
|
try
|
if dwDrawAspect <> DVASPECT_CONTENT then OleError(DV_E_DVASPECT);
|
W := MulDiv(Size.X, Screen.PixelsPerInch, 2540);
|
H := MulDiv(Size.Y, Screen.PixelsPerInch, 2540);
|
with FWinControl do SetBounds(Left, Top, W, H);
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
|
begin
|
if dwDrawAspect <> DVASPECT_CONTENT then
|
begin
|
Result := DV_E_DVASPECT;
|
Exit;
|
end;
|
Size.X := MulDiv(FWinControl.Width, 2540, Screen.PixelsPerInch);
|
Size.Y := MulDiv(FWinControl.Height, 2540, Screen.PixelsPerInch);
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
|
begin
|
Result := CreateAdviseHolder;
|
if Result = S_OK then
|
Result := FOleAdviseHolder.Advise(advSink, dwConnection);
|
end;
|
|
function TActiveXControl.Unadvise(dwConnection: Longint): HResult;
|
begin
|
Result := CreateAdviseHolder;
|
if Result = S_OK then
|
Result := FOleAdviseHolder.Unadvise(dwConnection);
|
end;
|
|
function TActiveXControl.EnumAdvise(out enumAdvise: IEnumStatData): HResult;
|
begin
|
Result := CreateAdviseHolder;
|
if Result = S_OK then
|
Result := FOleAdviseHolder.EnumAdvise(enumAdvise);
|
end;
|
|
function TActiveXControl.GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
|
begin
|
if dwAspect <> DVASPECT_CONTENT then
|
begin
|
Result := DV_E_DVASPECT;
|
Exit;
|
end;
|
dwStatus := FControlFactory.FMiscStatus;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.SetColorScheme(const logpal: TLogPalette): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
{ TActiveXControl.IOleControl }
|
|
function TActiveXControl.GetControlInfo(var ci: TControlInfo): HResult;
|
begin
|
with ci do
|
begin
|
cb := SizeOf(ci);
|
hAccel := 0;
|
cAccel := 0;
|
dwFlags := 0;
|
end;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.OnMnemonic(msg: PMsg): HResult;
|
begin
|
Result := InPlaceActivate(True);
|
end;
|
|
function TActiveXControl.OnAmbientPropertyChange(dispid: TDispID): HResult;
|
var
|
Font: TFont;
|
begin
|
if (FWinControl <> nil) and (FAmbientDispatch <> nil) then
|
begin
|
try
|
FWinControl.Perform(CM_PARENTCOLORCHANGED, 1, FAmbientDispatch.BackColor);
|
except
|
end;
|
FWinControl.Perform(CM_PARENTCTL3DCHANGED, 1, 1);
|
Font := TFont.Create;
|
try
|
Font.Color := FAmbientDispatch.ForeColor;
|
SetOleFont(Font, FAmbientDispatch.Font);
|
FWinControl.Perform(CM_PARENTFONTCHANGED, 1, Integer(Font));
|
except
|
end;
|
Font.Free;
|
end;
|
Result := S_OK; //OnAmbientPropChange MUST return S_OK in all cases.
|
end;
|
|
function TActiveXControl.FreezeEvents(bFreeze: BOOL): HResult;
|
begin
|
FEventsFrozen := bFreeze;
|
Result := S_OK;
|
end;
|
|
{ TActiveXControl.IOleWindow }
|
|
function TActiveXControl.GetWindow(out wnd: HWnd): HResult;
|
begin
|
if FWinControl.HandleAllocated then
|
begin
|
wnd := FWinControl.Handle;
|
Result := S_OK;
|
end else
|
Result := E_FAIL;
|
end;
|
|
function TActiveXControl.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
{ TActiveXControl.IOleInPlaceObject }
|
|
function TActiveXControl.InPlaceDeactivate: HResult;
|
begin
|
if FInPlaceActive then
|
begin
|
FInPlaceActive := False;
|
UIDeactivate;
|
FWinControl.Visible := False;
|
FWinControl.ParentWindow := ParkingWindow;
|
FOleInPlaceUIWindow := nil;
|
FOleInPlaceFrame := nil;
|
FOleInPlaceSite.OnInPlaceDeactivate;
|
FOleInPlaceSite := nil;
|
end;
|
FWinControl.Visible := False;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.UIDeactivate: HResult;
|
begin
|
if FUIActive then
|
begin
|
FUIActive := False;
|
if FOleInPlaceUIWindow <> nil then
|
FOleInPlaceUIWindow.SetActiveObject(nil, nil);
|
FOleInPlaceFrame.SetActiveObject(nil, nil);
|
FOleInPlaceSite.OnUIDeactivate(False);
|
end;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.SetObjectRects(const rcPosRect: TRect;
|
const rcClipRect: TRect): HResult;
|
var
|
IntersectionRect: TRect;
|
NewRegion: HRGN;
|
begin
|
try
|
if (@rcPosRect = nil) or (@rcClipRect = nil) then
|
begin
|
Result := E_POINTER;
|
Exit;
|
end
|
else if FWinControl.HandleAllocated then
|
begin
|
// The container thinks the control should clip, figure out if the control
|
// really needs to clip.
|
NewRegion := 0;
|
|
if IntersectRect(IntersectionRect, rcPosRect, rcClipRect) and
|
(not EqualRect(IntersectionRect, rcPosRect)) then
|
begin
|
OffsetRect(IntersectionRect, -rcPosRect.Left, -rcPosRect.Top);
|
NewRegion := CreateRectRgnIndirect(IntersectionRect);
|
end;
|
|
// Set the control's location.
|
SetWindowRgn(FWinControl.Handle, NewRegion, True);
|
FWinControl.BoundsRect := rcPosRect;
|
end;
|
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.ReactivateAndUndo: HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
{ TActiveXControl.IOleInPlaceActiveObject }
|
|
function TActiveXControl.TranslateAccelerator(var msg: TMsg): HResult;
|
var
|
Control: TWinControl;
|
Form: TCustomForm;
|
HWindow: THandle;
|
Mask: Integer;
|
begin
|
with Msg do
|
if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then
|
begin
|
Control := FindControl(HWnd);
|
if Control = nil then
|
begin
|
HWindow := HWnd;
|
repeat
|
HWindow := GetParent(HWindow);
|
if HWindow <> 0 then Control := FindControl(HWindow);
|
until (HWindow = 0) or (Control <> nil);
|
end;
|
if Control <> nil then
|
begin
|
Result := S_OK;
|
if (Message = WM_KEYDOWN) and (Control.Perform(CM_CHILDKEY, wParam, Integer(Control)) <> 0) then Exit;
|
Mask := 0;
|
case wParam of
|
VK_TAB:
|
Mask := DLGC_WANTTAB;
|
VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END:
|
Mask := DLGC_WANTARROWS;
|
VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
|
Mask := DLGC_WANTALLKEYS;
|
end;
|
if (Mask <> 0) and
|
((Control.Perform(CM_WANTSPECIALKEY, wParam, 0) <> 0) or
|
(Control.Perform(WM_GETDLGCODE, 0, 0) and Mask <> 0)) then
|
begin
|
TranslateMessage(msg);
|
DispatchMessage(msg);
|
Exit;
|
end;
|
if (Message = WM_KEYDOWN) and (Control.Parent <> nil) then
|
Form := GetParentForm(Control)
|
else
|
Form := nil;
|
if (Form <> nil) and (Form.Perform(CM_DIALOGKEY, wParam, lParam) = 1) then
|
Exit;
|
end;
|
end;
|
if FOleControlSite <> nil then
|
Result := FOleControlSite.TranslateAccelerator(@msg, GetKeyModifiers)
|
else
|
Result := S_FALSE;
|
end;
|
|
function TActiveXControl.OnFrameWindowActivate(fActivate: BOOL): HResult;
|
begin
|
Result := InPlaceActivate(True);
|
end;
|
|
function TActiveXControl.OnDocWindowActivate(fActivate: BOOL): HResult;
|
begin
|
Result := InPlaceActivate(fActivate);
|
end;
|
|
function TActiveXControl.ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
|
fFrameWindow: BOOL): HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.EnableModeless(fEnable: BOOL): HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
{ TActiveXControl.IViewObject }
|
|
function TActiveXControl.Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
|
ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
|
prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
|
dwContinue: Longint): HResult;
|
var
|
R: TRect;
|
SaveIndex: Integer;
|
WasVisible: Boolean;
|
begin
|
try
|
if dwDrawAspect <> DVASPECT_CONTENT then OleError(DV_E_DVASPECT);
|
WasVisible := FControl.Visible;
|
try
|
FControl.Visible := True;
|
ShowWindow(FWinControl.Handle, 1);
|
R := prcBounds^;
|
LPToDP(hdcDraw, R, 2);
|
SaveIndex := SaveDC(hdcDraw);
|
try
|
SetViewportOrgEx(hdcDraw, 0, 0, nil);
|
SetWindowOrgEx(hdcDraw, 0, 0, nil);
|
SetMapMode(hdcDraw, MM_TEXT);
|
FControl.PaintTo(hdcDraw, R.Left, R.Top);
|
finally
|
RestoreDC(hdcDraw, SaveIndex);
|
end;
|
finally
|
FControl.Visible := WasVisible;
|
end;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.GetColorSet(dwDrawAspect: Longint; lindex: Longint;
|
pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
|
out colorSet: PLogPalette): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
|
out dwFreeze: Longint): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.Unfreeze(dwFreeze: Longint): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.SetAdvise(aspects: Longint; advf: Longint;
|
const advSink: IAdviseSink): HResult;
|
begin
|
if aspects and DVASPECT_CONTENT = 0 then
|
begin
|
Result := DV_E_DVASPECT;
|
Exit;
|
end;
|
FAdviseFlags := advf;
|
FAdviseSink := advSink;
|
if FAdviseFlags and ADVF_PRIMEFIRST <> 0 then ViewChanged;
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.GetAdvise(pAspects: PLongint; pAdvf: PLongint;
|
out advSink: IAdviseSink): HResult;
|
begin
|
if pAspects <> nil then pAspects^ := DVASPECT_CONTENT;
|
if pAdvf <> nil then pAdvf^ := FAdviseFlags;
|
if @advSink <> nil then advSink := FAdviseSink;
|
Result := S_OK;
|
end;
|
|
{ TActiveXControl.IViewObject2 }
|
|
function TActiveXControl.ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
|
ptd: PDVTargetDevice; out size: TPoint): HResult;
|
begin
|
Result := GetExtent(dwDrawAspect, size);
|
end;
|
|
{ TActiveXControl.IPerPropertyBrowsing }
|
|
function TActiveXControl.GetDisplayString(dispid: TDispID;
|
out bstr: WideString): HResult;
|
var
|
S: string;
|
begin
|
Result := E_NOTIMPL;
|
if GetPropertyString( dispid, S ) then
|
begin
|
bstr := S;
|
Result := S_OK;
|
end;
|
end;
|
|
function TActiveXControl.MapPropertyToPage(dispid: TDispID;
|
out clsid: TCLSID): HResult;
|
begin
|
if @clsid <> nil then clsid := GUID_NULL;
|
Result := E_NOTIMPL; {+ !!}
|
end;
|
|
function TActiveXControl.GetPredefinedStrings(dispid: TDispID;
|
out caStringsOut: TCAPOleStr; out caCookiesOut: TCALongint): HResult;
|
var
|
StringList: POleStrList;
|
CookieList: PLongintList;
|
Strings: TStringList;
|
Count, I: Integer;
|
begin
|
StringList := nil;
|
CookieList := nil;
|
Count := 0;
|
if (@CaStringsOut = nil) or (@CaCookiesOut = nil) then
|
begin
|
Result := E_POINTER;
|
Exit;
|
end;
|
caStringsOut.cElems := 0;
|
caStringsOut.pElems := nil;
|
caCookiesOut.cElems := 0;
|
caCookiesOut.pElems := nil;
|
|
try
|
Strings := TStringList.Create;
|
try
|
if GetPropertyStrings(dispid, Strings) then
|
begin
|
Count := Strings.Count;
|
StringList := CoAllocMem(Count * SizeOf(Pointer));
|
CookieList := CoAllocMem(Count * SizeOf(Longint));
|
for I := 0 to Count - 1 do
|
begin
|
StringList[I] := CoAllocString(Strings[I]);
|
CookieList[I] := Longint(Strings.Objects[I]);
|
end;
|
caStringsOut.cElems := Count;
|
caStringsOut.pElems := StringList;
|
caCookiesOut.cElems := Count;
|
caCookiesOut.pElems := CookieList;
|
Result := S_OK;
|
end else
|
Result := E_NOTIMPL;
|
finally
|
Strings.Free;
|
end;
|
except
|
if StringList <> nil then
|
for I := 0 to Count - 1 do CoFreeMem(StringList[I]);
|
CoFreeMem(CookieList);
|
CoFreeMem(StringList);
|
Result := HandleException;
|
end;
|
end;
|
|
function TActiveXControl.GetPredefinedValue(dispid: TDispID;
|
dwCookie: Longint; out varOut: OleVariant): HResult;
|
var
|
Temp: OleVariant;
|
begin
|
GetPropertyValue(dispid, dwCookie, Temp);
|
varOut := Temp;
|
Result := S_OK;
|
end;
|
|
{ TActiveXControl.ISpecifyPropertyPages }
|
|
type
|
TPropPages = class
|
private
|
FGUIDList: PGUIDList;
|
FCount: Integer;
|
procedure ProcessPage(const GUID: TGUID);
|
end;
|
|
procedure TPropPages.ProcessPage(const GUID: TGUID);
|
begin
|
if FGUIDList <> nil then FGUIDList[FCount] := GUID;
|
Inc(FCount);
|
end;
|
|
function TActiveXControl.GetPages(out pages: TCAGUID): HResult;
|
var
|
PropPages: TPropPages;
|
begin
|
try
|
PropPages := TPropPages.Create;
|
try
|
DefinePropertyPages(PropPages.ProcessPage);
|
PropPages.FGUIDList := CoAllocMem(PropPages.FCount * SizeOf(TGUID));
|
PropPages.FCount := 0;
|
DefinePropertyPages(PropPages.ProcessPage);
|
pages.cElems := PropPages.FCount;
|
pages.pElems := PropPages.FGUIDList;
|
PropPages.FGUIDList := nil;
|
finally
|
if PropPages.FGUIDList <> nil then CoFreeMem(PropPages.FGUIDList);
|
PropPages.Free;
|
end;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
{ ISimpleFrameSite }
|
|
function TActiveXControl.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
|
out res: Integer; out Cookie: Longint): HResult;
|
begin
|
if FSimpleFrameSite <> nil then
|
Result := FSimpleFrameSite.PreMessageFilter(wnd, msg, wp, lp, res, Cookie)
|
else
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
|
out res: Integer; Cookie: Longint): HResult;
|
begin
|
if FSimpleFrameSite <> nil then
|
Result := FSimpleFrameSite.PostMessageFilter(wnd, msg, wp, lp, res, Cookie)
|
else
|
Result := S_OK;
|
end;
|
|
{ IQuickActivate }
|
|
function TActiveXControl.QuickActivate(var qaCont: TQaContainer; var qaCtrl: TQaControl): HResult; stdcall;
|
var
|
Connections: IConnectionPointContainer;
|
EventConnection: IConnectionPoint;
|
PropConnection: IConnectionPoint;
|
begin
|
// Verify that caller allocated enough space
|
if qaCtrl.cbSize < SizeOf(TQaControl) then
|
begin
|
Result := E_UNEXPECTED;
|
Exit;
|
end;
|
// Initialize TQaControl structure
|
FillChar(qaCtrl, SizeOf(TQaControl), 0);
|
qaCtrl.cbSize := SizeOf(TQaControl);
|
// Set ClientSite
|
SetClientSite(qaCont.pClientSite);
|
// Set Advise Sink
|
if qaCont.pAdviseSink <> nil then
|
SetAdvise(DVASPECT_CONTENT, 0, qaCont.pAdviseSink);
|
// Grab ConnectionPointContainer
|
Connections := Self as IConnectionPointContainer;
|
// Hook up Property Notify Sink
|
if qaCont.pPropertyNotifySink <> nil then
|
begin
|
if Connections.FindConnectionPoint(IPropertyNotifySink, EventConnection) = S_OK then
|
EventConnection.Advise(qaCont.pPropertyNotifySink, qaCtrl.dwPropNotifyCookie);
|
end;
|
// Hook up default outgoing interface
|
if qaCont.pUnkEventSink <> nil then
|
begin
|
if Connections.FindConnectionPoint(FControlFactory.EventIID, PropConnection) = S_OK then
|
PropConnection.Advise(qaCont.pUnkEventSink, qaCtrl.dwEventCookie);
|
end;
|
// Give information to Container
|
GetMiscStatus(DVASPECT_CONTENT, qaCtrl.dwMiscStatus);
|
// Return SUCCESS
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.SetContentExtent(const sizel: TPoint): HResult; stdcall;
|
begin
|
Result := SetExtent(DVASPECT_CONTENT, sizel);
|
end;
|
|
function TActiveXControl.GetContentExtent(out sizel: TPoint): HResult; stdcall;
|
begin
|
Result := GetExtent(DVASPECT_CONTENT, sizel);
|
end;
|
|
|
{ IDataObject }
|
|
function TActiveXControl.GetData(const formatetcIn: TFormatEtc;
|
out medium: TStgMedium): HResult; stdcall;
|
var
|
sizeMetric: TPoint;
|
dc: HDC;
|
hMF: HMetafile;
|
hMem: THandle;
|
pMFP: PMetafilePict;
|
SaveVisible: Boolean;
|
BM: TBitmap;
|
begin
|
// Handle only MetaFile
|
if (formatetcin.tymed and TYMED_MFPICT) = 0 then
|
begin
|
Result := DV_E_FORMATETC;
|
Exit;
|
end;
|
// Retrieve Extent
|
GetExtent(DVASPECT_CONTENT, sizeMetric);
|
// Create Metafile DC and set it up
|
dc := CreateMetafile(nil);
|
SetWindowOrgEx(dc, 0, 0, nil);
|
SetWindowExtEx(dc, sizemetric.X, sizemetric.Y, nil);
|
// Have Control paint to DC and get metafile handle
|
SaveVisible := FControl.Visible;
|
try
|
FControl.Visible := True;
|
BM := TBitmap.Create;
|
try
|
BM.Width := FControl.Width;
|
BM.Height := FControl.Height;
|
FControl.PaintTo(BM.Canvas.Handle, 0, 0);
|
StretchBlt(dc, 0, 0, sizeMetric.X, sizeMetric.Y,
|
BM.Canvas.Handle, 0, 0, BM.Width, BM.Height, SRCCOPY);
|
finally
|
BM.Free;
|
end;
|
finally
|
FControl.Visible := SaveVisible;
|
end;
|
hMF := CloseMetaFile(dc);
|
if hMF = 0 then
|
begin
|
Result := E_UNEXPECTED;
|
Exit;
|
end;
|
|
// Get memory handle
|
hMEM := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE, sizeof(METAFILEPICT));
|
if hMEM = 0 then
|
begin
|
DeleteMetafile(hMF);
|
Result := STG_E_MEDIUMFULL;
|
Exit;
|
end;
|
pMFP := PMetaFilePict(GlobalLock(hMEM));
|
pMFP^.hMF := hMF;
|
pMFP^.mm := MM_ANISOTROPIC;
|
pMFP^.xExt := sizeMetric.X;
|
pMFP^.yExt := sizeMetric.Y;
|
GlobalUnlock(hMEM);
|
|
medium.tymed := TYMED_MFPICT;
|
medium.hGlobal := hMEM;
|
medium.UnkForRelease := nil;
|
|
Result := S_OK;
|
end;
|
|
function TActiveXControl.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium):
|
HResult; stdcall;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.QueryGetData(const formatetc: TFormatEtc): HResult;
|
stdcall;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
|
out formatetcOut: TFormatEtc): HResult; stdcall;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
|
fRelease: BOOL): HResult; stdcall;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
|
IEnumFormatEtc): HResult; stdcall;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TActiveXControl.DAdvise(const formatetc: TFormatEtc; advf: Longint;
|
const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
|
begin
|
Result := S_OK;
|
if FDataAdviseHolder = nil then
|
Result := CreateDataAdviseHolder(FDataAdviseHolder);
|
if Result = S_OK then
|
Result := FDataAdviseHolder.Advise(Self, formatetc, advf, advSink, dwConnection);
|
end;
|
|
function TActiveXControl.DUnadvise(dwConnection: Longint): HResult; stdcall;
|
begin
|
if FDataAdviseHolder = nil then
|
Result := OLE_E_NOCONNECTION
|
else
|
Result := FDataAdviseHolder.Unadvise(dwConnection);
|
end;
|
|
function TActiveXControl.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
|
stdcall;
|
begin
|
if FDataAdviseHolder = nil then
|
Result := E_FAIL
|
else
|
Result := FDataAdviseHolder.EnumAdvise(enumAdvise);
|
end;
|
|
|
{ TActiveXControlFactory }
|
|
constructor TActiveXControlFactory.Create(ComServer: TComServerObject;
|
ActiveXControlClass: TActiveXControlClass;
|
WinControlClass: TWinControlClass; const ClassID: TGUID;
|
ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer;
|
ThreadingModel: TThreadingModel);
|
begin
|
FWinControlClass := WinControlClass;
|
inherited Create(ComServer, ActiveXControlClass, ClassID, ciMultiInstance,
|
ThreadingModel);
|
FMiscStatus := MiscStatus or
|
OLEMISC_RECOMPOSEONRESIZE or
|
OLEMISC_CANTLINKINSIDE or
|
OLEMISC_INSIDEOUT or
|
OLEMISC_ACTIVATEWHENVISIBLE or
|
OLEMISC_SETCLIENTSITEFIRST;
|
FToolboxBitmapID := ToolboxBitmapID;
|
FVerbs := TStringList.Create;
|
AddVerb(OLEIVERB_PRIMARY, SPropertiesVerb);
|
LicString := LicStr;
|
SupportsLicensing := LicStr <> '';
|
FLicFileStrings := TStringList.Create;
|
end;
|
|
destructor TActiveXControlFactory.Destroy;
|
begin
|
FVerbs.Free;
|
FLicFileStrings.Free;
|
inherited Destroy;
|
end;
|
|
procedure TActiveXControlFactory.AddVerb(Verb: Integer;
|
const VerbName: string);
|
begin
|
FVerbs.AddObject(VerbName, TObject(Verb));
|
end;
|
|
function TActiveXControlFactory.GetLicenseFileName: string;
|
begin
|
Result := ChangeFileExt(ComServer.ServerFileName, '.lic');
|
end;
|
|
function TActiveXControlFactory.HasMachineLicense: Boolean;
|
var
|
i: Integer;
|
begin
|
Result := True;
|
if not SupportsLicensing then Exit;
|
if not FLicenseFileRead then
|
begin
|
try
|
FLicFileStrings.LoadFromFile(GetLicenseFileName);
|
FLicenseFileRead := True;
|
except
|
Result := False;
|
end;
|
end;
|
if Result then
|
begin
|
i := 0;
|
Result := False;
|
while (i < FLicFileStrings.Count) and (not Result) do
|
begin
|
Result := ValidateUserLicense(FLicFileStrings[i]);
|
inc(i);
|
end;
|
end;
|
end;
|
|
procedure TActiveXControlFactory.UpdateRegistry(Register: Boolean);
|
var
|
ClassKey: string;
|
I: Integer;
|
begin
|
ClassKey := 'CLSID\' + GUIDToString(ClassID);
|
if Register then
|
begin
|
inherited UpdateRegistry(Register);
|
CreateRegKey(ClassKey + '\MiscStatus', '', '0');
|
CreateRegKey(ClassKey + '\MiscStatus\1', '', IntToStr(FMiscStatus));
|
CreateRegKey(ClassKey + '\ToolboxBitmap32', '',
|
ComServer.ServerFileName + ',' + IntToStr(FToolboxBitmapID));
|
CreateRegKey(ClassKey + '\Control', '', '');
|
CreateRegKey(ClassKey + '\Verb', '', '');
|
for I := 0 to FVerbs.Count - 1 do
|
CreateRegKey(ClassKey + '\Verb\' + IntToStr(Integer(FVerbs.Objects[I])),
|
'', FVerbs[I] + ',0,2');
|
end else
|
begin
|
for I := 0 to FVerbs.Count - 1 do
|
DeleteRegKey(ClassKey + '\Verb\' + IntToStr(Integer(FVerbs.Objects[I])));
|
DeleteRegKey(ClassKey + '\Verb');
|
DeleteRegKey(ClassKey + '\Control');
|
DeleteRegKey(ClassKey + '\ToolboxBitmap32');
|
DeleteRegKey(ClassKey + '\MiscStatus\1');
|
DeleteRegKey(ClassKey + '\MiscStatus');
|
inherited UpdateRegistry(Register);
|
end;
|
end;
|
|
{ TActiveFormControl }
|
|
procedure TActiveFormControl.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
|
begin
|
if FControl is TActiveForm then
|
TActiveForm(FControl).DefinePropertyPages(DefinePropertyPage);
|
end;
|
|
procedure TActiveFormControl.FreeOnRelease;
|
begin
|
end;
|
|
procedure TActiveFormControl.InitializeControl;
|
begin
|
inherited InitializeControl;
|
FControl.VCLComObject := Pointer(Self as IVCLComObject);
|
if FControl is TActiveForm then
|
begin
|
TActiveForm(FControl).FActiveFormControl := Self;
|
TActiveForm(FControl).Initialize;
|
end;
|
end;
|
|
function TActiveFormControl.Invoke(DispID: Integer; const IID: TGUID;
|
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
|
ArgErr: Pointer): HResult;
|
const
|
INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
|
begin
|
if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
|
Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
|
Integer(Control) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
|
DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
|
end;
|
|
function TActiveFormControl.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
|
begin
|
Result := S_OK;
|
if IsEqualGUID(IID, IUnknown) or not Control.GetInterface(IID, Obj) then
|
Result := inherited ObjQueryInterface(IID, Obj);
|
end;
|
|
procedure TActiveFormControl.EventSinkChanged(const EventSink: IUnknown);
|
begin
|
if (Control is TActiveForm) then
|
TActiveForm(Control).EventSinkChanged(EventSink);
|
end;
|
|
{ TActiveForm }
|
|
procedure TActiveForm.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
|
begin
|
end;
|
|
procedure TActiveForm.DoDestroy;
|
begin
|
if Assigned(OnDestroy) then
|
try
|
OnDestroy(Self);
|
OnDestroy := nil;
|
except
|
Application.HandleException(Self);
|
end;
|
end;
|
|
procedure TActiveForm.EventSinkChanged(const EventSink: IUnknown);
|
begin
|
if (FSinkChangeCount = 0) and (EventSink <> nil) then
|
DoCreate;
|
InterLockedIncrement(FSinkChangeCount);
|
end;
|
|
procedure TActiveForm.Initialize;
|
begin
|
end;
|
|
{ TActiveFormFactory }
|
|
function TActiveFormFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
|
begin
|
Result := WinControlClass.GetInterfaceEntry(Guid);
|
end;
|
|
{ TPropertyPage }
|
|
constructor TPropertyPage.Create(AOwner: TComponent);
|
begin
|
inherited Create(AOwner);
|
FOleObjects := TInterfaceList.Create;
|
end;
|
|
destructor TPropertyPage.Destroy;
|
begin
|
FOleObjects.Free;
|
inherited Destroy;
|
end;
|
|
procedure TPropertyPage.CMChanged(var Msg: TCMChanged);
|
begin
|
Modified;
|
end;
|
|
procedure TPropertyPage.Modified;
|
begin
|
if Assigned(FActiveXPropertyPage) then FActiveXPropertyPage.Modified;
|
end;
|
|
procedure TPropertyPage.UpdateObject;
|
begin
|
end;
|
|
procedure TPropertyPage.EnumCtlProps(PropType: TGUID; PropNames: TStrings);
|
begin
|
EnumDispatchProperties(IUnknown(FOleObject) as IDispatch, PropType, VT_EMPTY,
|
PropNames);
|
end;
|
|
procedure TPropertyPage.UpdatePropertyPage;
|
begin
|
end;
|
|
{ TActiveXPropertyPage }
|
|
destructor TActiveXPropertyPage.Destroy;
|
begin
|
FPropertyPageImpl.FPropertyPage.Free;
|
FPropertyPageImpl.Free;
|
end;
|
|
procedure TActiveXPropertyPage.Initialize;
|
begin
|
FPropertyPageImpl := TPropertyPageImpl.Create(Self);
|
FPropertyPageImpl.FPropertyPage := TPropertyPageClass(Factory.ComClass).Create(nil);
|
FPropertyPageImpl.InitPropertyPage;
|
end;
|
|
{ TPropertyPageImpl }
|
|
procedure TPropertyPageImpl.InitPropertyPage;
|
begin
|
FPropertyPage.FActiveXPropertyPage := Self;
|
FPropertyPage.BorderStyle := bsNone;
|
FPropertyPage.Position := poDesigned;
|
end;
|
|
procedure TPropertyPageImpl.Modified;
|
begin
|
if FActive then
|
begin
|
FModified := True;
|
if FPageSite <> nil then
|
FPageSite.OnStatusChange(PROPPAGESTATUS_DIRTY or PROPPAGESTATUS_VALIDATE);
|
end;
|
end;
|
|
{ TPropertyPageImpl.IPropertyPage }
|
|
function TPropertyPageImpl.SetPageSite(const pageSite: IPropertyPageSite): HResult;
|
begin
|
FPageSite := pageSite;
|
Result := S_OK;
|
end;
|
|
function TPropertyPageImpl.Activate(hwndParent: HWnd; const rc: TRect;
|
bModal: BOOL): HResult;
|
begin
|
try
|
FPropertyPage.BoundsRect := rc;
|
FPropertyPage.ParentWindow := hwndParent;
|
FActive:= True;
|
FModified := False;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TPropertyPageImpl.Deactivate: HResult;
|
begin
|
try
|
FActive := False;
|
FPropertyPage.Hide;
|
FPropertyPage.ParentWindow := 0;
|
FPropertyPage.FOleObject := null;
|
FPropertyPage.FOleObjects.Clear;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TPropertyPageImpl.GetPageInfo(out pageInfo: TPropPageInfo): HResult;
|
begin
|
try
|
FillChar(pageInfo.pszTitle, SizeOf(pageInfo) - 4, 0);
|
pageInfo.pszTitle := CoAllocString(FPropertyPage.Caption);
|
pageInfo.size.cx := FPropertyPage.Width;
|
pageInfo.size.cy := FPropertyPage.Height;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TPropertyPageImpl.SetObjects(cObjects: Longint;
|
pUnkList: PUnknownList): HResult;
|
var
|
i: Integer;
|
begin
|
try
|
FPropertyPage.FOleObject := Null;
|
FPropertyPage.FOleObjects.Clear;
|
if pUnkList = nil then
|
begin
|
Result := E_POINTER;
|
Exit;
|
end;
|
if cObjects > 0 then
|
begin
|
for i := 0 to cObjects - 1 do
|
FPropertyPage.FOleObjects.Add(pUnkList[i]);
|
FPropertyPage.FOleObject := pUnkList[0] as IDispatch;
|
end;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
|
if not VarIsNull(FPropertyPage.FOleObject) then
|
FPropertyPage.UpdatePropertyPage;
|
end;
|
|
function TPropertyPageImpl.Show(nCmdShow: Integer): HResult;
|
begin
|
try
|
FPropertyPage.Visible := nCmdShow <> SW_HIDE;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TPropertyPageImpl.Move(const rect: TRect): HResult;
|
begin
|
try
|
FPropertyPage.BoundsRect := rect;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TPropertyPageImpl.IsPageDirty: HResult;
|
begin
|
if FModified then Result := S_OK else Result := S_FALSE;
|
end;
|
|
function TPropertyPageImpl.Apply: HResult;
|
|
procedure NotifyContainerOfApply;
|
var
|
OleObject: IUnknown;
|
Connections: IConnectionPointContainer;
|
Connection: IConnectionPoint;
|
Enum: IEnumConnections;
|
ConnectData: TConnectData;
|
Fetched: Longint;
|
begin
|
{ VB seems to wait for an OnChange call along a IPropetyNotifySink before
|
it will update its property inspector. }
|
OleObject := IUnknown(FPropertyPage.FOleObject);
|
if OleObject.QueryInterface(IConnectionPointContainer, Connections) = S_OK then
|
if Connections.FindConnectionPoint(IPropertyNotifySink, Connection) = S_OK then
|
begin
|
OleCheck(Connection.EnumConnections(Enum));
|
while Enum.Next(1, ConnectData, @Fetched) = S_OK do
|
begin
|
(ConnectData.pUnk as IPropertyNotifySink).OnChanged(DISPID_UNKNOWN);
|
ConnectData.pUnk := nil;
|
end;
|
end;
|
end;
|
|
begin
|
try
|
FPropertyPage.UpdateObject;
|
FModified := False;
|
NotifyContainerOfApply;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TPropertyPageImpl.Help(pszHelpDir: POleStr): HResult;
|
begin
|
Result := E_NOTIMPL;
|
end;
|
|
function TPropertyPageImpl.TranslateAccelerator(msg: PMsg): HResult;
|
begin
|
try
|
{ For some reason VB bashes WS_EX_CONTROLPARENT, set it back }
|
if FPropertyPage.WindowHandle <> 0 then
|
SetWindowLong(FPropertyPage.Handle, GWL_EXSTYLE,
|
GetWindowLong(FPropertyPage.Handle, GWL_EXSTYLE) or
|
WS_EX_CONTROLPARENT);
|
{+ !!}
|
Result := S_FALSE;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
{ TPropertyPageImpl.IPropertyPage2 }
|
|
function TPropertyPageImpl.EditProperty(dispid: TDispID): HResult;
|
begin
|
Result := E_NOTIMPL; {+ !!}
|
end;
|
|
{ TActiveXPropertyPageFactory }
|
|
constructor TActiveXPropertyPageFactory.Create(ComServer: TComServerObject;
|
PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
|
begin
|
inherited Create(ComServer, TComClass(PropertyPageClass), ClassID,
|
'', Format('%s property page', [PropertyPageClass.ClassName]),
|
ciMultiInstance);
|
end;
|
|
function TActiveXPropertyPageFactory.CreateComObject(
|
const Controller: IUnknown): TComObject;
|
begin
|
Result := TActiveXPropertyPage.CreateFromFactory(Self, Controller);
|
end;
|
|
{ TCustomAdapter }
|
|
constructor TCustomAdapter.Create;
|
begin
|
inherited Create;
|
FNotifier := TAdapterNotifier.Create(Self);
|
end;
|
|
destructor TCustomAdapter.Destroy;
|
begin
|
ReleaseOleObject;
|
inherited Destroy;
|
end;
|
|
procedure TCustomAdapter.Changed;
|
begin
|
if not Updating then ReleaseOleObject;
|
end;
|
|
procedure TCustomAdapter.ConnectOleObject(OleObject: IUnknown);
|
begin
|
if FOleObject <> nil then ReleaseOleObject;
|
if OleObject <> nil then
|
InterfaceConnect(OleObject, IPropertyNotifySink, FNotifier, FConnection);
|
FOleObject := OleObject;
|
end;
|
|
procedure TCustomAdapter.ReleaseOleObject;
|
begin
|
InterfaceDisconnect(FOleObject, IPropertyNotifySink, FConnection);
|
FOleObject := nil;
|
end;
|
|
{ TAdapterNotifier }
|
|
constructor TAdapterNotifier.Create(Adapter: TCustomAdapter);
|
begin
|
inherited Create;
|
FAdapter := Adapter;
|
end;
|
|
{ TAdapterNotifier.IPropertyNotifySink }
|
|
function TAdapterNotifier.OnChanged(dispid: TDispID): HResult;
|
begin
|
try
|
FAdapter.Update;
|
Result := S_OK;
|
except
|
Result := HandleException;
|
end;
|
end;
|
|
function TAdapterNotifier.OnRequestEdit(dispid: TDispID): HResult;
|
begin
|
Result := S_OK;
|
end;
|
|
{ TFontAdapter }
|
|
constructor TFontAdapter.Create(Font: TFont);
|
begin
|
inherited Create;
|
FFont := Font;
|
end;
|
|
procedure TFontAdapter.Update;
|
var
|
TempFont: TFont;
|
Name: WideString;
|
Size: Currency;
|
Temp: Longbool;
|
Charset: Smallint;
|
Style: TFontStyles;
|
FOleFont: IFont;
|
begin
|
if Updating then Exit;
|
FOleFont := FOleObject as IFont;
|
if FOleFont = nil then Exit;
|
FOleFont.get_Name(Name);
|
FOleFont.get_Size(Size);
|
|
Style := [];
|
FOleFont.get_Bold(Temp);
|
if Temp then Include(Style, fsBold);
|
FOleFont.get_Italic(Temp);
|
if Temp then Include(Style, fsItalic);
|
FOleFont.get_Underline(Temp);
|
if Temp then Include(Style, fsUnderline);
|
FOleFont.get_Strikethrough(Temp);
|
if Temp then Include(Style, fsStrikeout);
|
FOleFont.get_Charset(Charset);
|
|
TempFont := TFont.Create;
|
Updating := True;
|
try
|
TempFont.Assign(FFont);
|
TempFont.Name := Name;
|
TempFont.Size := Integer(Round(Size));
|
TempFont.Style := Style;
|
TempFont.Charset := Charset;
|
FFont.Assign(TempFont);
|
finally
|
Updating := False;
|
TempFont.Free;
|
end;
|
end;
|
|
procedure TFontAdapter.Changed;
|
begin // TFont has changed. Need to update IFont
|
if Updating then Exit;
|
if FOleObject = nil then Exit;
|
Updating := True;
|
try
|
with FOleObject as IFont do
|
begin
|
Put_Name(FFont.Name);
|
Put_Size(FFont.Size);
|
Put_Bold(fsBold in FFont.Style);
|
Put_Italic(fsItalic in FFont.Style);
|
Put_Underline(fsUnderline in FFont.Style);
|
Put_Strikethrough(fsStrikeout in FFont.Style);
|
Put_Charset(FFont.Charset);
|
end;
|
finally
|
Updating := False;
|
end;
|
end;
|
|
{ TFontAdapter.IFontAccess }
|
|
procedure TFontAdapter.GetOleFont(var OleFont: IFontDisp);
|
var
|
FontDesc: TFontDesc;
|
FontName: WideString;
|
Temp: IFont;
|
begin
|
if FOleObject = nil then
|
begin
|
FontName := FFont.Name;
|
with FontDesc do
|
begin
|
cbSizeOfStruct := SizeOf(FontDesc);
|
lpstrName := PWideChar(FontName);
|
cySize := FFont.Size;
|
if fsBold in FFont.Style then sWeight := 700 else sWeight := 400;
|
sCharset := FFont.Charset;
|
fItalic := fsItalic in FFont.Style;
|
fUnderline := fsUnderline in FFont.Style;
|
fStrikethrough := fsStrikeout in FFont.Style;
|
end;
|
OleCheck(OleCreateFontIndirect(FontDesc, IFont, Temp));
|
ConnectOleObject(Temp);
|
end;
|
OleFont := FOleObject as IFontDisp;
|
end;
|
|
procedure TFontAdapter.SetOleFont(const OleFont: IFontDisp);
|
begin
|
ConnectOleObject(OleFont as IFont);
|
Update;
|
end;
|
|
{ TPictureAdapter }
|
|
constructor TPictureAdapter.Create(Picture: TPicture);
|
begin
|
inherited Create;
|
FPicture := Picture;
|
end;
|
|
procedure TPictureAdapter.Update;
|
var
|
Temp: TOleGraphic;
|
begin
|
Updating := True;
|
Temp := TOleGraphic.Create;
|
try
|
Temp.Picture := FOleObject as IPicture;
|
FPicture.Graphic := Temp;
|
finally
|
Updating := False;
|
Temp.Free;
|
end;
|
end;
|
|
{ TPictureAdapter.IPictureAccess }
|
|
procedure TPictureAdapter.GetOlePicture(var OlePicture: IPictureDisp);
|
var
|
PictureDesc: TPictDesc;
|
OwnHandle: Boolean;
|
TempM: TMetafile;
|
TempB: TBitmap;
|
begin
|
if FOleObject = nil then
|
begin
|
OwnHandle := False;
|
with PictureDesc do
|
begin
|
cbSizeOfStruct := SizeOf(PictureDesc);
|
if FPicture.Graphic is TBitmap then
|
begin
|
picType := PICTYPE_BITMAP;
|
TempB := TBitmap.Create;
|
try
|
TempB.Assign(FPicture.Graphic);
|
hbitmap := TempB.ReleaseHandle;
|
hpal := TempB.ReleasePalette;
|
OwnHandle := True;
|
finally
|
TempB.Free;
|
end;
|
end
|
else if FPicture.Graphic is TIcon then
|
begin
|
picType := PICTYPE_ICON;
|
hicon := FPicture.Icon.Handle;
|
end
|
else
|
begin
|
picType := PICTYPE_ENHMETAFILE;
|
if not (FPicture.Graphic is TMetafile) then
|
begin
|
TempM := TMetafile.Create;
|
try
|
TempM.Width := FPicture.Width;
|
TempM.Height := FPicture.Height;
|
with TMetafileCanvas.Create(TempM,0) do
|
try
|
Draw(0,0,FPicture.Graphic);
|
finally
|
Free;
|
end;
|
hemf := TempM.ReleaseHandle;
|
OwnHandle := True; // IPicture destroys temp metafile when released
|
finally
|
TempM.Free;
|
end;
|
end
|
else
|
hemf := FPicture.Metafile.Handle;
|
end;
|
end;
|
OleCheck(OleCreatePictureIndirect(PictureDesc, IPicture, OwnHandle, OlePicture));
|
ConnectOleObject(OlePicture);
|
end;
|
OlePicture := FOleObject as IPictureDisp;
|
end;
|
|
procedure TPictureAdapter.SetOlePicture(const OlePicture: IPictureDisp);
|
begin
|
ConnectOleObject(OlePicture);
|
Update;
|
end;
|
|
{ TOleGraphic }
|
|
procedure TOleGraphic.Assign(Source: TPersistent);
|
begin
|
if Source is TOleGraphic then
|
FPicture := TOleGraphic(Source).Picture
|
else
|
inherited Assign(Source);
|
end;
|
|
procedure TOleGraphic.Changed(Sender: TObject);
|
begin
|
//!!
|
end;
|
|
procedure TOleGraphic.Draw(ACanvas: TCanvas; const Rect: TRect);
|
var
|
DC: HDC;
|
Pal: HPalette;
|
RestorePalette: Boolean;
|
PicType: SmallInt;
|
hemf: HENHMETAFILE;
|
begin
|
if FPicture = nil then Exit;
|
ACanvas.Lock; // OLE calls might cycle the message loop
|
try
|
DC := ACanvas.Handle;
|
Pal := Palette;
|
RestorePalette := False;
|
if Pal <> 0 then
|
begin
|
Pal := SelectPalette(DC, Pal, True);
|
RealizePalette(DC);
|
RestorePalette := True;
|
end;
|
FPicture.get_Type(PicType);
|
if PicType = PICTYPE_ENHMETAFILE then
|
begin
|
FPicture.get_Handle(hemf);
|
PlayEnhMetafile(DC, hemf, Rect);
|
end
|
else
|
OleCheck(FPicture.Render(DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
|
Rect.Bottom - Rect.Top, 0, MMHeight - 1, MMWidth, -MMHeight, Rect));
|
if RestorePalette then
|
SelectPalette(DC, Pal, True);
|
finally
|
ACanvas.Unlock;
|
end;
|
end;
|
|
function TOleGraphic.GetEmpty: Boolean;
|
var
|
PicType: Smallint;
|
begin
|
Result := (FPicture = nil) or (FPicture.get_Type(PicType) <> 0) or (PicType <= 0);
|
end;
|
|
function HIMETRICtoDP(P: TPoint): TPoint;
|
var
|
DC: HDC;
|
begin
|
DC := GetDC(0);
|
SetMapMode(DC, MM_HIMETRIC);
|
Result := P;
|
Result.Y := -Result.Y;
|
LPTODP(DC, Result, 1);
|
ReleaseDC(0,DC);
|
end;
|
|
function TOleGraphic.GetHeight: Integer;
|
begin
|
Result := HIMETRICtoDP(Point(0, MMHeight)).Y;
|
end;
|
|
function TOleGraphic.GetMMHeight: Integer;
|
begin
|
Result := 0;
|
if FPicture <> nil then FPicture.get_Height(Result);
|
end;
|
|
function TOleGraphic.GetMMWidth: Integer;
|
begin
|
Result := 0;
|
if FPicture <> nil then FPicture.get_Width(Result);
|
end;
|
|
function TOleGraphic.GetPalette: HPALETTE;
|
var
|
Handle: OLE_HANDLE;
|
begin
|
Result := 0;
|
if FPicture <> nil then
|
begin
|
FPicture.Get_HPal(Handle);
|
Result := HPALETTE(Handle);
|
end;
|
end;
|
|
function TOleGraphic.GetTransparent: Boolean;
|
var
|
Attr: Integer;
|
begin
|
Result := False;
|
if FPicture <> nil then
|
begin
|
FPicture.Get_Attributes(Attr);
|
Result := (Attr and PICTURE_TRANSPARENT) <> 0;
|
end;
|
end;
|
|
function TOleGraphic.GetWidth: Integer;
|
begin
|
Result := HIMETRICtoDP(Point(MMWidth,0)).X;
|
end;
|
|
procedure InvalidOperation(const Str: string);
|
begin
|
raise EInvalidGraphicOperation.Create(Str);
|
end;
|
|
procedure TOleGraphic.SetHeight(Value: Integer);
|
begin
|
InvalidOperation(sOleGraphic);
|
end;
|
|
procedure TOleGraphic.SetPalette(Value: HPALETTE);
|
begin
|
if FPicture <> nil then OleCheck(FPicture.Set_hpal(Value));
|
end;
|
|
procedure TOleGraphic.SetWidth(Value: Integer);
|
begin
|
InvalidOperation(sOleGraphic);
|
end;
|
|
procedure TOleGraphic.LoadFromFile(const Filename: string);
|
begin
|
//!!
|
end;
|
|
procedure TOleGraphic.LoadFromStream(Stream: TStream);
|
begin
|
OleCheck(OleLoadPicture(TStreamAdapter.Create(Stream), 0, True, IPicture,
|
FPicture));
|
end;
|
|
procedure TOleGraphic.SaveToStream(Stream: TStream);
|
begin
|
OleCheck((FPicture as IPersistStream).Save(TStreamAdapter.Create(Stream), True));
|
end;
|
|
procedure TOleGraphic.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
|
APalette: HPALETTE);
|
begin
|
InvalidOperation(sOleGraphic);
|
end;
|
|
procedure TOleGraphic.SaveToClipboardFormat(var AFormat: Word;
|
var AData: THandle; var APalette: HPALETTE);
|
begin
|
InvalidOperation(sOleGraphic);
|
end;
|
|
|
type
|
TStringsEnumerator = class(TContainedObject, IEnumString)
|
private
|
FIndex: Integer; // index of next unread string
|
FStrings: IStrings;
|
public
|
constructor Create(const Strings: IStrings);
|
function Next(celt: Longint; out elt;
|
pceltFetched: PLongint): HResult; stdcall;
|
function Skip(celt: Longint): HResult; stdcall;
|
function Reset: HResult; stdcall;
|
function Clone(out enm: IEnumString): HResult; stdcall;
|
end;
|
|
constructor TStringsEnumerator.Create(const Strings: IStrings);
|
begin
|
inherited Create(Strings);
|
FStrings := Strings;
|
end;
|
|
function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
|
var
|
I: Integer;
|
begin
|
I := 0;
|
while (I < celt) and (FIndex < FStrings.Count) do
|
begin
|
TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[I]));
|
Inc(I);
|
Inc(FIndex);
|
end;
|
if pceltFetched <> nil then pceltFetched^ := I;
|
if I = celt then Result := S_OK else Result := S_FALSE;
|
end;
|
|
function TStringsEnumerator.Skip(celt: Longint): HResult;
|
begin
|
if (FIndex + celt) <= FStrings.Count then
|
begin
|
Inc(FIndex, celt);
|
Result := S_OK;
|
end
|
else
|
begin
|
FIndex := FStrings.Count;
|
Result := S_FALSE;
|
end;
|
end;
|
|
function TStringsEnumerator.Reset: HResult;
|
begin
|
FIndex := 0;
|
Result := S_OK;
|
end;
|
|
function TStringsEnumerator.Clone(out enm: IEnumString): HResult;
|
begin
|
try
|
enm := TStringsEnumerator.Create(FStrings);
|
Result := S_OK;
|
except
|
Result := E_UNEXPECTED;
|
end;
|
end;
|
|
{ TStringsAdapter }
|
|
constructor TStringsAdapter.Create(Strings: TStrings);
|
var
|
StdVcl: ITypeLib;
|
begin
|
OleCheck(LoadRegTypeLib(LIBID_STDVCL, 4, 0, 0, StdVcl));
|
inherited Create(StdVcl, IStrings);
|
FStrings := Strings;
|
end;
|
|
procedure TStringsAdapter.ReferenceStrings(S: TStrings);
|
begin
|
FStrings := S;
|
end;
|
|
procedure TStringsAdapter.ReleaseStrings;
|
begin
|
FStrings := nil;
|
end;
|
|
function TStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant;
|
begin
|
Result := Get_Item(Index);
|
end;
|
|
procedure TStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant);
|
begin
|
Set_Item(Index, Value);
|
end;
|
|
function TStringsAdapter.Count: Integer;
|
begin
|
Result := 0;
|
if FStrings <> nil then Result := FStrings.Count;
|
end;
|
|
function TStringsAdapter.Get_Item(Index: Integer): OleVariant;
|
begin
|
Result := NULL;
|
if (FStrings <> nil) then Result := WideString(FStrings[Index]);
|
end;
|
|
procedure TStringsAdapter.Set_Item(Index: Integer; Value: OleVariant);
|
begin
|
if (FStrings <> nil) then FStrings[Index] := Value;
|
end;
|
|
procedure TStringsAdapter.Remove(Index: Integer);
|
begin
|
if FStrings <> nil then FStrings.Delete(Index);
|
end;
|
|
procedure TStringsAdapter.Clear;
|
begin
|
if FStrings <> nil then FStrings.Clear;
|
end;
|
|
function TStringsAdapter.Add(Item: OleVariant): Integer;
|
begin
|
Result := -1;
|
if FStrings <> nil then Result := FStrings.Add(Item);
|
end;
|
|
function TStringsAdapter._NewEnum: IUnknown;
|
begin
|
Result := TStringsEnumerator.Create(Self);
|
end;
|
|
procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
|
begin
|
OleStrings := nil;
|
if Strings = nil then Exit;
|
if Strings.StringsAdapter = nil then
|
Strings.StringsAdapter := TStringsAdapter.Create(Strings);
|
OleStrings := Strings.StringsAdapter as IStrings;
|
end;
|
|
procedure SetOleStrings(Strings: TStrings; OleStrings: IStrings);
|
var
|
I: Integer;
|
begin
|
if Strings = nil then Exit;
|
Strings.BeginUpdate;
|
try
|
Strings.Clear;
|
for I := 0 to OleStrings.Count-1 do
|
Strings.Add(OleStrings.Item[I]);
|
finally
|
Strings.EndUpdate;
|
end;
|
end;
|
|
{ Dynamically load functions used in OLEPRO32.DLL }
|
|
var
|
OlePro32DLL: THandle;
|
_OleCreatePropertyFrame: function(hwndOwner: HWnd; x, y: Integer;
|
lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
|
pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
|
pvReserved: Pointer): HResult stdcall;
|
_OleCreateFontIndirect: function(const FontDesc: TFontDesc; const iid: TIID;
|
out vObject): HResult stdcall;
|
_OleCreatePictureIndirect: function(const PictDesc: TPictDesc; const iid: TIID;
|
fOwn: BOOL; out vObject): HResult stdcall;
|
_OleLoadPicture: function(stream: IStream; lSize: Longint; fRunmode: BOOL;
|
const iid: TIID; out vObject): HResult; stdcall;
|
|
procedure InitOlePro32;
|
begin
|
if OlePro32Dll <> 0 then Exit;
|
{$IFDEF MSWINDOWS}
|
OlePro32Dll := SafeLoadLibrary('olepro32.dll');
|
{$ENDIF}
|
if OlePro32DLL <> 0 then
|
begin
|
@_OleCreatePropertyFrame := GetProcAddress(OlePro32DLL, 'OleCreatePropertyFrame');
|
@_OleCreateFontIndirect := GetProcAddress(OlePro32DLL, 'OleCreateFontIndirect');
|
@_OleCreatePictureIndirect := GetProcAddress(OlePro32DLL, 'OleCreatePictureIndirect');
|
@_OleLoadPicture := GetProcAddress(OlePro32DLL, 'OleLoadPicture');
|
end;
|
end;
|
|
function OleCreatePropertyFrame(hwndOwner: HWnd; x, y: Integer;
|
lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
|
pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
|
pvReserved: Pointer): HResult;
|
begin
|
if Assigned(_OleCreatePropertyFrame) then
|
Result := _OleCreatePropertyFrame(hwndOwner, x, y, lpszCaption, cObjects,
|
pObjects, cPages, pPageCLSIDs, lcid, dwReserved, pvReserved)
|
else
|
Result := E_UNEXPECTED;
|
end;
|
|
function OleCreateFontIndirect(const FontDesc: TFontDesc; const iid: TIID;
|
out vObject): HResult;
|
begin
|
if Assigned(_OleCreateFontIndirect) then
|
Result := _OleCreateFontIndirect(FontDesc, iid, vObject)
|
else
|
Result := E_UNEXPECTED;
|
end;
|
|
function OleCreatePictureIndirect(const PictDesc: TPictDesc; const iid: TIID;
|
fOwn: BOOL; out vObject): HResult;
|
begin
|
if Assigned(_OleCreatePictureIndirect) then
|
Result := _OleCreatePictureIndirect(PictDesc, iid, fOwn, vObject)
|
else
|
Result := E_UNEXPECTED;
|
end;
|
|
function OleLoadPicture(stream: IStream; lSize: Longint; fRunmode: BOOL;
|
const iid: TIID; out vObject): HResult;
|
begin
|
if Assigned(_OleLoadPicture) then
|
Result := _OleLoadPicture(stream, lSize, fRunmode, iid, vObject)
|
else
|
Result := E_UNEXPECTED;
|
end;
|
|
initialization
|
TPicture.RegisterFileFormat('', '', TOleGraphic);
|
InitOlePro32;
|
|
finalization
|
if xParkingWindow <> 0 then
|
begin
|
SendMessage(xParkingWindow, WM_CLOSE, 0, 0);
|
Windows.UnregisterClass('DAXParkingWindow', HInstance);
|
end;
|
if OlePro32DLL <> 0 then FreeLibrary(OlePro32DLL);
|
|
end.
|
