diff options
| author | Vadim Dashevskiy <watcherhd@gmail.com> | 2012-10-08 18:43:29 +0000 |
|---|---|---|
| committer | Vadim Dashevskiy <watcherhd@gmail.com> | 2012-10-08 18:43:29 +0000 |
| commit | 864081102a5f252415f41950b3039a896b4ae9c5 (patch) | |
| tree | c6b764651e9dd1f8f53b98eab05f16ba4a492a79 /plugins/Libs/ActiveKOL.pas | |
| parent | db5149b48346c417e18add5702a9dfe7f6e28dd0 (diff) | |
Awkwars's plugins - welcome to our trunk
git-svn-id: http://svn.miranda-ng.org/main/trunk@1822 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c
Diffstat (limited to 'plugins/Libs/ActiveKOL.pas')
| -rw-r--r-- | plugins/Libs/ActiveKOL.pas | 2649 |
1 files changed, 2649 insertions, 0 deletions
diff --git a/plugins/Libs/ActiveKOL.pas b/plugins/Libs/ActiveKOL.pas new file mode 100644 index 0000000000..6f62f0c50d --- /dev/null +++ b/plugins/Libs/ActiveKOL.pas @@ -0,0 +1,2649 @@ +{This version is compatible with KOL 3.00+ -- VK}
+
+unit ActiveKOL;
+
+interface
+
+uses
+ windows, messages, KOL, ActiveX, KOLComObj, err;
+
+{$I KOLDEF.INC}
+{$IFDEF _D6orHigher}
+ //{$WARN SYMBOL_DEPRECATED OFF}
+ {$WARN SYMBOL_PLATFORM OFF}
+ {$IFDEF _D7orHigher}
+ {$WARN UNSAFE_TYPE OFF}
+ {$WARN UNSAFE_CAST OFF}
+ {$WARN UNSAFE_CODE OFF}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFNDEF _D5orHigher}
+const
+ sNoRunningObject = 'Unable to retrieve a pointer to a running object registered with OLE for %s/%s';
+{$ENDIF}
+
+type
+ POleCtl = ^TOleCtl;
+
+ TEventDispatch = class(TObject, IUnknown, IDispatch)
+ private
+ FControl: POleCtl;
+ protected
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ { IDispatch }
+ function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+ function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+ function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+ function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+ property Control: POleCtl read FControl;
+ public
+ constructor Create(Control: POleCtl);
+ end;
+
+ {$IFNDEF _D5orHigher}
+ TOleEnum = type Integer;
+ //{$NODEFINE TOleEnum}
+ {$ENDIF}
+
+ TGetStrProc = procedure(const S: string) of object;
+
+ TEnumValue = record
+ Value: Longint;
+ Ident: string;
+ end;
+
+ PEnumValueList = ^TEnumValueList;
+ TEnumValueList = array[0..32767] of TEnumValue;
+
+ PEnumPropDesc = ^TEnumPropDesc;
+ TEnumPropDesc = object(TObj)
+ private
+ FDispID: Integer;
+ FValueCount: Integer;
+ FValues: PEnumValueList;
+ public
+ constructor Create(DispID, ValueCount: Integer;
+ const TypeInfo: ITypeInfo);
+ destructor Destroy; virtual;
+ procedure GetStrings(Proc: TGetStrProc);
+ function StringToValue(const S: string): Integer;
+ function ValueToString(V: Integer): string;
+ end;
+
+ PControlData = ^TControlData;
+ TControlData = record
+ ClassID: TGUID;
+ EventIID: TGUID;
+ EventCount: Longint;
+ EventDispIDs: Pointer;
+ LicenseKey: Pointer;
+ Flags: DWORD;
+ Version: Integer;
+ FontCount: Integer;
+ FontIDs: PDispIDList;
+ PictureCount: Integer;
+ PictureIDs: PDispIDList;
+ Reserved: Integer;
+ InstanceCount: Integer;
+ EnumPropDescs: PList;
+ end;
+
+ PControlData2 = ^TControlData2;
+ TControlData2 = record
+ ClassID: TGUID;
+ EventIID: TGUID;
+ EventCount: Longint;
+ EventDispIDs: Pointer;
+ LicenseKey: Pointer;
+ Flags: DWORD;
+ Version: Integer;
+ FontCount: Integer;
+ FontIDs: PDispIDList;
+ PictureCount: Integer;
+ PictureIDs: PDispIDList;
+ Reserved: Integer;
+ InstanceCount: Integer;
+ EnumPropDescs: PList;
+ FirstEventOfs: Cardinal;
+ end;
+
+ TOleCtlIntfClass = class of TOleCtlIntf;
+ TOleCtlIntf = class( TObject, IUnknown, IOleClientSite,
+ IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch,
+ IPropertyNotifySink, ISimpleFrameSite)
+ private
+ FRefCount: Integer;
+ fOleCtl: POleCtl;
+ procedure GetEventMethod(DispID: TDispID; var Method: TMethod);
+ protected
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ { IOleClientSite }
+ function SaveObject: HResult; stdcall;
+ function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
+ out mk: IMoniker): HResult; stdcall;
+ function GetContainer(out container: IOleContainer): HResult; stdcall;
+ function ShowObject: HResult; stdcall;
+ function OnShowWindow(fShow: BOOL): HResult; stdcall;
+ function RequestNewObjectLayout: HResult; stdcall;
+ { IOleControlSite }
+ function OnControlInfoChanged: HResult; stdcall;
+ function LockInPlaceActive(fLock: BOOL): HResult; stdcall;
+ function GetExtendedControl(out disp: IDispatch): HResult; stdcall;
+ function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
+ flags: Longint): HResult; stdcall;
+ function IOleControlSite.TranslateAccelerator = OleControlSite_TranslateAccelerator;
+ function OleControlSite_TranslateAccelerator(msg: PMsg;
+ grfModifiers: Longint): HResult; stdcall;
+ function OnFocus(fGotFocus: BOOL): HResult; stdcall;
+ function ShowPropertyFrame: HResult; stdcall;
+ { IOleWindow }
+ function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
+ { IOleInPlaceSite }
+ function IOleInPlaceSite.GetWindow = OleInPlaceSite_GetWindow;
+ function OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; stdcall;
+ function CanInPlaceActivate: HResult; stdcall;
+ function OnInPlaceActivate: HResult; stdcall;
+ function OnUIActivate: HResult; stdcall;
+ function GetWindowContext(out frame: IOleInPlaceFrame;
+ out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
+ out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
+ stdcall;
+ function Scroll(scrollExtent: TPoint): HResult; stdcall;
+ function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall;
+ function OnInPlaceDeactivate: HResult; stdcall;
+ function DiscardUndoState: HResult; stdcall;
+ function DeactivateAndUndo: HResult; stdcall;
+ function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall;
+ { IOleInPlaceUIWindow }
+ function GetBorder(out rectBorder: TRect): HResult; stdcall;
+ function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
+ function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
+ function SetActiveObject(const activeObject: IOleInPlaceActiveObject;
+ pszObjName: POleStr): HResult; stdcall;
+ { IOleInPlaceFrame }
+ function IOleInPlaceFrame.GetWindow = OleInPlaceFrame_GetWindow;
+ function OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; stdcall;
+ function InsertMenus(hmenuShared: HMenu;
+ var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
+ function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
+ hwndActiveObject: HWnd): HResult; stdcall;
+ function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
+ function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
+ function EnableModeless(fEnable: BOOL): HResult; stdcall;
+ function IOleInPlaceFrame.TranslateAccelerator = OleInPlaceFrame_TranslateAccelerator;
+ function OleInPlaceFrame_TranslateAccelerator(var msg: Windows.TMsg;
+ wID: Word): HResult; stdcall;
+ { IDispatch }
+ function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+ function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+ function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+ function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): 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;
+ { IPropertyNotifySink }
+ function OnChanged(dispid: TDispID): HResult; virtual; stdcall;
+ function OnRequestEdit(dispid: TDispID): HResult; virtual; stdcall;
+ public
+ property OleCtl: POleCtl read fOleCtl;
+ constructor Create; virtual;
+ end;
+
+
+ TOnGetIntfClass = function(): TOleCtlIntfClass of object;
+
+
+ TOleCtl = object( TControl )
+ private
+ FOnGetIntfClass: TOnGetIntfClass;
+ function GetOleObject: Variant;
+ procedure CreateInstance;
+ function GetOnLeave: TOnEvent;
+ procedure SetOnLeave(const Value: TOnEvent);
+ procedure HookControlWndProc;
+ procedure SetUIActive(Active: Boolean);
+ procedure CreateControl;
+ procedure DestroyStorage;
+ procedure DestroyControl;
+ procedure StandardEvent(DispID: TDispID; var Params: TDispParams);
+ //procedure SetMouseDblClk(const Value: TOnMouse);
+ procedure SetOnChar(const Value: TOnChar);
+ protected
+ //{$IFDEF DELPHI_CODECOMPLETION_BUG}
+ fNotAvailable: Boolean;
+ //{$ENDIF}
+ {$IFNDEF USE_NAMES}
+ fName: String;
+ {$ENDIF}
+ FControlData: PControlData;
+ FOleObject: IOleObject;
+ FMiscStatus: Longint;
+ FFonts: PList;
+ FPictures: PList;
+ FEventDispatch: TEventDispatch;
+ fOleCtlIntf: TOleCtlIntf;
+ FPersistStream: IPersistStreamInit;
+ FOleInPlaceObject: IOleInPlaceObject;
+ FOleInPlaceActiveObject: IOleInPlaceActiveObject;
+ FOleControl: IOleControl;
+ FUpdatingColor: Boolean;
+ FUpdatingFont: Boolean;
+ FUpdatingEnabled: Boolean;
+ FObjectData: HGlobal;
+ FControlDispatch: IDispatch;
+ FPropBrowsing: IPerPropertyBrowsing;
+ FPropConnection: Longint;
+ FEventsConnection: Longint;
+ fCreatingWnd: Boolean;
+ procedure Init; virtual;
+ procedure InitControlData; virtual;
+ procedure InitControlInterface(const Obj: IUnknown); virtual;
+ property ControlData: PControlData read FControlData write FControlData;
+ function GetMainMenu: HMenu;
+ procedure InvokeEvent(DispID: TDispID; var Params: TDispParams);
+ procedure D2InvokeEvent(DispID: TDispID; var Params: TDispParams);
+ procedure DoHandleException;
+ procedure CreateEnumPropDescs;
+ procedure DestroyEnumPropDescs;
+
+ property OnGetIntfClass: TOnGetIntfClass read FOnGetIntfClass write FOnGetIntfClass;
+ public
+ function GetByteProp(Index: Integer): Byte;
+ function GetColorProp(Index: Integer): TColor;
+ function GetTColorProp(Index: Integer): TColor;
+ function GetCompProp(Index: Integer): Comp;
+ function GetCurrencyProp(Index: Integer): Currency;
+ function GetDoubleProp(Index: Integer): Double;
+ function GetIDispatchProp(Index: Integer): IDispatch;
+ function GetIntegerProp(Index: Integer): Integer;
+ function GetIUnknownProp(Index: Integer): IUnknown;
+ function GetWordBoolProp(Index: Integer): WordBool;
+ function GetTDateTimeProp(Index: Integer): TDateTime;
+ function GetTFontProp(Index: Integer): PGraphicTool;
+ function GetOleBoolProp(Index: Integer): TOleBool;
+ function GetOleDateProp(Index: Integer): TOleDate;
+ function GetOleEnumProp(Index: Integer): TOleEnum;
+ function GetTOleEnumProp(Index: Integer): TOleEnum;
+ function GetOleVariantProp(Index: Integer): OleVariant;
+ //function GetTPictureProp(Index: Integer): TPicture;
+ procedure GetProperty(Index: Integer; var Value: TVarData);
+ function GetShortIntProp(Index: Integer): ShortInt;
+ function GetSingleProp(Index: Integer): Single;
+ function GetSmallintProp(Index: Integer): Smallint;
+ function GetStringProp(Index: Integer): string;
+ function GetVariantProp(Index: Integer): Variant;
+ function GetWideStringProp(Index: Integer): WideString;
+ function GetWordProp(Index: Integer): Word;
+ procedure SetByteProp(Index: Integer; Value: Byte);
+ procedure SetColorProp(Index: Integer; Value: TColor);
+ procedure SetTColorProp(Index: Integer; Value: TColor);
+ procedure SetCompProp(Index: Integer; const Value: Comp);
+ procedure SetCurrencyProp(Index: Integer; const Value: Currency);
+ procedure SetDoubleProp(Index: Integer; const Value: Double);
+ procedure SetIDispatchProp(Index: Integer; const Value: IDispatch);
+ procedure SetIntegerProp(Index: Integer; Value: Integer);
+ procedure SetIUnknownProp(Index: Integer; const Value: IUnknown);
+ procedure SetName(const Value: String); virtual;
+ procedure SetWordBoolProp(Index: Integer; Value: WordBool);
+ procedure SetTDateTimeProp(Index: Integer; const Value: TDateTime);
+ procedure SetTFontProp(Index: Integer; Value:PGraphicTool);
+ procedure SetOleBoolProp(Index: Integer; Value: TOleBool);
+ procedure SetOleDateProp(Index: Integer; const Value: TOleDate);
+ procedure SetOleEnumProp(Index: Integer; Value: TOleEnum);
+ procedure SetTOleEnumProp(Index: Integer; Value: TOleEnum);
+ procedure SetOleVariantProp(Index: Integer; const Value: OleVariant);
+ procedure SetParent(AParent: PControl); virtual;
+ //procedure SetTPictureProp(Index: Integer; Value: TPicture);
+ procedure SetProperty(Index: Integer; const Value: TVarData);
+ procedure SetShortIntProp(Index: Integer; Value: Shortint);
+ procedure SetSingleProp(Index: Integer; const Value: Single);
+ procedure SetSmallintProp(Index: Integer; Value: Smallint);
+ procedure SetStringProp(Index: Integer; const Value: string);
+ procedure SetVariantProp(Index: Integer; const Value: Variant);
+ procedure SetWideStringProp(Index: Integer; const Value: WideString);
+ procedure SetWordProp(Index: Integer; Value: Word);
+
+ function GetEnumPropDesc(DispID: Integer): PEnumPropDesc;
+
+ property DragCursor: Boolean read fNotAvailable;
+ property DragMode : Boolean read fNotAvailable;
+ property ParentShowHint: Boolean read fNotAvailable;
+ property PopupMenu: Boolean read fNotAvailable;
+ property ShowHint: Boolean read fNotAvailable;
+ property OnDragDrop: Boolean read fNotAvailable;
+ property OnDragOver: Boolean read fNotAvailable;
+ property OnEndDrag: Boolean read fNotAvailable;
+ property OnStartDrag: Boolean read fNotAvailable;
+
+ property OnExit: TOnEvent read GetOnLeave write SetOnLeave;
+ property OleObject: Variant read GetOleObject;
+
+ property Name: String read fName write fName;
+ function CreateWindow: Boolean; virtual;
+ procedure DblClk;
+ procedure KeyDown(var Key: Longint; AShift: DWORD);
+ procedure KeyUp(var Key: Longint; AShift: DWORD);
+ procedure KeyPress(var Key: KOLChar);
+ procedure MouseDown(Button: TMouseButton; AShift: DWORD;
+ X, Y: Integer);
+ procedure MouseMove(AShift: DWORD; X, Y: Integer);
+ procedure MouseUp(Button: TMouseButton; AShift: DWORD;
+ X, Y: Integer);
+
+ property OnKeyPress: TOnChar
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF}
+ write SetOnChar;
+ property OnDblClick: TOnMouse index idx_fOnMouseDblClk
+ read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDblClk {$ENDIF}
+ write SetOnMouseEvent; // SetMouseDblClk;
+
+ destructor Destroy; virtual;
+
+ end;
+
+{$IFNDEF _D2orD3}
+type
+ TVariantArray = Array of OleVariant;
+ TOleServer = class;
+ TConnectKind = (ckRunningOrNew, // Attach to a running or create a new instance of the server
+ ckNewInstance, // Create a new instance of the server
+ ckRunningInstance, // Attach to a running instance of the server
+ ckRemote, // Bind to a remote instance of the server
+ ckAttachToInterface); // Don't bind to server, user will provide interface via 'CpnnectTo'
+
+ TServerEventDispatch = class(TObject, IUnknown, IDispatch)
+ private
+ FServer: TOleServer;
+ InternalRefCount : Integer;
+ protected
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+ { IDispatch }
+ function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
+ function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
+ function GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
+ function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
+ Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
+ property Server: TOleServer read FServer;
+ function ServerDisconnect :Boolean;
+ public
+ constructor Create(Server: TOleServer);
+ end;
+
+ PServerData = ^TServerData;
+ TServerData = record
+ ClassID: TGUID; // CLSID of CoClass
+ IntfIID: TGUID; // IID of default interface
+ EventIID: TGUID; // IID of default source interface
+ LicenseKey: Pointer; // Pointer to license string (not implemented)
+ Version: Integer; // Version of this structure
+ InstanceCount: Integer; // Instance of the Server running
+ end;
+
+ TOleServer = class(TObject, IUnknown)
+ private
+ FServerData: PServerData;
+ FRefCount: Longint;
+ FEventDispatch: TServerEventDispatch;
+ FEventsConnection: Longint;
+ FAutoConnect: Boolean;
+ FRemoteMachineName: string;
+ FConnectKind: TConnectKind;
+
+ protected
+ { IUnknown }
+ function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override;
+ function _AddRef: Integer; stdcall;
+ function _Release: Integer; stdcall;
+
+ procedure Loaded; //override;
+ procedure InitServerData; virtual; abstract;
+
+ function GetServer: IUnknown; virtual;
+
+ procedure ConnectEvents(const Obj: IUnknown);
+ procedure DisconnectEvents(const Obj: Iunknown);
+ procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); virtual;
+
+ function GetConnectKind: TConnectKind;
+ procedure SetConnectKind(ck: TConnectKind);
+
+ function GetAutoConnect: Boolean;
+ procedure SetAutoConnect(flag: Boolean);
+
+ property ServerData: PServerData read FServerData write FServerData;
+ property EventDispatch: TServerEventDispatch read FEventDispatch write FEventDispatch;
+
+ public
+ constructor Create; //(AOwner: TComponent); override;
+ destructor Destroy; override;
+
+ // NOTE: If derived class is generated by TLIBIMP or ImportTypeLibraryCodeGenerator,
+ // the derived class will also expose a 'ConnectTo(interface)' function.
+ // You must invoke that method if you're using 'ckAttachToInterface' connection
+ // kind.
+ procedure Connect; virtual; abstract;
+ procedure Disconnect; virtual; abstract;
+
+ published
+ property AutoConnect: Boolean read GetAutoConnect write SetAutoConnect;
+ property ConnectKind: TConnectKind read GetConnectKind write SetConnectKind;
+ property RemoteMachineName: string read FRemoteMachineName write FRemoteMachineName;
+ end;
+{$ENDIF}
+
+var
+ EmptyParam: OleVariant; { "Empty parameter" standard constant which can be
+ passed as an optional parameter on a dual interface. }
+
+
+implementation
+
+uses
+ OleConst;
+
+const
+ // The following flags may be or'd into the TControlData.Reserved field to override
+ // default behaviors.
+
+ // cdForceSetClientSite:
+ // Call SetClientSite early (in constructor) regardless of misc status flags
+ cdForceSetClientSite = 1;
+
+ // cdDeferSetClientSite:
+ // Don't call SetClientSite early. Takes precedence over cdForceSetClientSite and misc status flags
+ cdDeferSetClientSite = 2;
+
+const
+ cfBackColor = $00000001;
+ cfForeColor = $00000002;
+ cfFont = $00000004;
+ cfEnabled = $00000008;
+ cfCaption = $00000010;
+ cfText = $00000020;
+
+const
+ MaxDispArgs = 32;
+
+type
+
+ PDispInfo = ^TDispInfo;
+ TDispInfo = packed record
+ DispID: TDispID;
+ ResType: Byte;
+ CallDesc: TCallDesc;
+ end;
+
+ TArgKind = (akDWord, akSingle, akDouble);
+
+ PEventArg = ^TEventArg;
+ TEventArg = record
+ Kind: TArgKind;
+ Data: array[0..1] of Integer;
+ end;
+
+ TEventInfo = record
+ Method: TMethod;
+ Sender: TObject;
+ ArgCount: Integer;
+ Args: array[0..MaxDispArgs - 1] of TEventArg;
+ end;
+
+function StringToVarOleStr(const S: string): Variant;
+begin
+ VarClear(Result);
+ TVarData(Result).VOleStr := StringToOleStr(S);
+ TVarData(Result).VType := varOleStr;
+end;
+
+{ TEnumPropDesc }
+
+constructor TEnumPropDesc.Create(DispID, ValueCount: Integer;
+ const TypeInfo: ITypeInfo);
+var
+ I: Integer;
+ VarDesc: PVarDesc;
+ XName: WideString;
+begin
+ FDispID := DispID;
+ FValueCount := ValueCount;
+ FValues := AllocMem(ValueCount * SizeOf(TEnumValue));
+ for I := 0 to ValueCount - 1 do
+ begin
+ OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
+ try
+ OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @XName,
+ nil, nil, nil));
+ with FValues^[I] do
+ begin
+ Value := TVarData(VarDesc^.lpVarValue^).VInteger;
+ Ident := XName;
+ while (Length(Ident) > 1) and (Ident[1] = '_') do
+ Delete(Ident, 1, 1);
+ end;
+ finally
+ TypeInfo.ReleaseVarDesc(VarDesc);
+ end;
+ end;
+end;
+
+destructor TEnumPropDesc.Destroy;
+begin
+ if FValues <> nil then
+ begin
+ Finalize(FValues^[0], FValueCount);
+ FreeMem(FValues, FValueCount * SizeOf(TEnumValue));
+ end;
+ inherited;
+end;
+
+procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc);
+var
+ I: Integer;
+begin
+ for I := 0 to FValueCount - 1 do
+ with FValues^[I] do Proc(Format('%d - %s', [Value, Ident]));
+end;
+
+function TEnumPropDesc.StringToValue(const S: string): Integer;
+var
+ I: Integer;
+begin
+ I := 1;
+ while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I);
+ if I > 1 then
+ begin
+ Result := Str2Int(Copy(S, 1, I - 1));
+ for I := 0 to FValueCount - 1 do
+ if Result = FValues^[I].Value then Exit;
+ end else
+ for I := 0 to FValueCount - 1 do
+ with FValues^[I] do
+ if AnsiCompareText(S, Ident) = 0 then
+ begin
+ Result := Value;
+ Exit;
+ end;
+ raise EOleError.CreateResFmt(e_Ole, Integer( @SBadPropValue ), [S]);
+end;
+
+function TEnumPropDesc.ValueToString(V: Integer): string;
+var
+ I: Integer;
+begin
+ for I := 0 to FValueCount - 1 do
+ with FValues^[I] do
+ if V = Value then
+ begin
+ Result := Format('%d - %s', [Value, Ident]);
+ Exit;
+ end;
+ Result := Int2Str(V);
+end;
+
+{ TOleCtl }
+
+procedure TOleCtl.CreateControl;
+var
+ Stream: IStream;
+ CS: IOleClientSite;
+ X: Integer;
+begin
+ if FOleControl = nil then
+ try
+ try // work around ATL bug
+ X := FOleObject.GetClientSite(CS);
+ except
+ X := -1;
+ end;
+ if (X <> 0) or (CS = nil) then
+ OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
+ if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else
+ begin
+ OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
+ OleCheck(FPersistStream.Load(Stream));
+ DestroyStorage;
+ end;
+ OleCheck(FOleObject.QueryInterface(IOleControl, FOleControl));
+ OleCheck(FOleObject.QueryInterface(IDispatch, FControlDispatch));
+ FOleObject.QueryInterface(IPerPropertyBrowsing, FPropBrowsing);
+ InterfaceConnect(FOleObject, IPropertyNotifySink,
+ fOleCtlIntf, FPropConnection);
+ InterfaceConnect(FOleObject, FControlData^.EventIID,
+ FEventDispatch, FEventsConnection);
+ if FControlData^.Flags and cfBackColor <> 0 then
+ fOleCtlIntf.OnChanged(DISPID_BACKCOLOR);
+ if FControlData^.Flags and cfEnabled <> 0 then
+ fOleCtlIntf.OnChanged(DISPID_ENABLED);
+ if FControlData^.Flags and cfFont <> 0 then
+ fOleCtlIntf.OnChanged(DISPID_FONT);
+ if FControlData^.Flags and cfForeColor <> 0 then
+ fOleCtlIntf.OnChanged(DISPID_FORECOLOR);
+ FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN);
+ fOleCtlIntf.RequestNewObjectLayout;
+ except
+ DestroyControl;
+ raise;
+ end;
+end;
+
+procedure TOleCtl.CreateEnumPropDescs;
+
+ function FindMember(DispId: Integer): Boolean;
+ begin
+ Result := GetEnumPropDesc(DispId) <> nil;
+ end;
+ {var
+ I: Integer;
+ begin
+ for I := 0 to FControlData^.EnumPropDescs.Count - 1 do
+ if TEnumPropDesc(FControlData^.EnumPropDescs).FDispID = DispID then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Result := False;
+ end;}
+
+ procedure CreateEnum(TypeDesc: TTypeDesc; const TypeInfo: ITypeInfo;
+ DispId: Integer);
+ var
+ RefInfo: ITypeInfo;
+ RefAttr: PTypeAttr;
+ epd: PEnumPropDesc;
+ begin
+ if TypeDesc.vt <> VT_USERDEFINED then Exit;
+ OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo));
+ OleCheck(RefInfo.GetTypeAttr(RefAttr));
+ try
+ if RefAttr^.typekind = TKIND_ENUM then
+ begin
+ new( epd, Create(Dispid, RefAttr^.cVars, RefInfo) );
+ FControlData^.EnumPropDescs.Add( epd );
+ end;
+ finally
+ RefInfo.ReleaseTypeAttr(RefAttr);
+ end;
+ end;
+
+ procedure ProcessTypeInfo(const TypeInfo: ITypeInfo);
+ var
+ I: Integer;
+ RefInfo: ITypeInfo;
+ TypeAttr: PTypeAttr;
+ VarDesc: PVarDesc;
+ FuncDesc: PFuncDesc;
+ RefType: HRefType;
+ begin
+ OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
+ try
+ if IsEqualGUID(TypeAttr^.guid, IDispatch) then Exit;
+ if ((TypeAttr.typekind = TKIND_INTERFACE) or
+ (TypeAttr.wTypeFlags and TYPEFLAG_FDUAL <> 0)) and
+ (TypeAttr.wTypeFlags and TYPEFLAG_FNONEXTENSIBLE <> 0) then
+ begin
+ OleCheck(TypeInfo.GetRefTypeOfImplType(0, RefType));
+ OleCheck(TypeInfo.GetRefTypeInfo(RefType, RefInfo));
+ ProcessTypeInfo(RefInfo);
+ end;
+ for I := 0 to TypeAttr^.cVars - 1 do
+ begin
+ OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
+ try
+ CreateEnum(VarDesc^.elemdescVar.tdesc, TypeInfo, VarDesc^.memid);
+ finally
+ TypeInfo.ReleaseVarDesc(VarDesc);
+ end;
+ end;
+ for I := 0 to TypeAttr^.cFuncs - 1 do
+ begin
+ OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
+ try
+ if not FindMember(FuncDesc^.memid) then
+ case FuncDesc^.invkind of
+ INVOKE_PROPERTYGET:
+ CreateEnum(FuncDesc^.elemdescFunc.tdesc, TypeInfo, FuncDesc^.memid);
+ INVOKE_PROPERTYPUT:
+ CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc,
+ TypeInfo, FuncDesc^.memid);
+ INVOKE_PROPERTYPUTREF:
+ if FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.vt = VT_PTR then
+ CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.ptdesc^,
+ TypeInfo, FuncDesc^.memid);
+ end;
+ finally
+ TypeInfo.ReleaseFuncDesc(FuncDesc);
+ end;
+ end;
+ finally
+ TypeInfo.ReleaseTypeAttr(TypeAttr);
+ end;
+ end;
+
+var
+ TypeInfo: ITypeInfo;
+begin
+ CreateControl;
+ FControlData^.EnumPropDescs := NewList;
+ try
+ OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo));
+ ProcessTypeInfo(TypeInfo);
+ except
+ DestroyEnumPropDescs;
+ raise;
+ end;
+end;
+
+procedure TOleCtl.CreateInstance;
+var
+ ClassFactory2: IClassFactory2;
+ LicKeyStr: WideString;
+
+ procedure LicenseCheck(Status: HResult; const Ident: string);
+ begin
+ if Status = CLASS_E_NOTLICENSED then
+ raise EOleError.CreateFmt(e_Ole, Ident, [SubClassName]);
+ OleCheck(Status);
+ end;
+
+begin
+ if (FControlData^.LicenseKey <> nil) then
+ begin
+ OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or
+ CLSCTX_LOCAL_SERVER, nil, IClassFactory2, ClassFactory2));
+ LicKeyStr := PWideChar(FControlData^.LicenseKey);
+ LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IOleObject,
+ LicKeyStr, FOleObject), SInvalidLicense);
+ end else
+ LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil,
+ CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject,
+ FOleObject), SNotLicensed);
+end;
+
+procedure CallEventMethod(const EventInfo: TEventInfo);
+asm
+ PUSH EBX
+ PUSH ESI
+ PUSH EBP
+ MOV EBP,ESP
+ MOV EBX,EAX
+ MOV EDX,[EBX].TEventInfo.ArgCount
+ TEST EDX,EDX
+ JE @@5
+ XOR EAX,EAX
+ LEA ESI,[EBX].TEventInfo.Args
+@@1: MOV AL,[ESI].TEventArg.Kind
+ CMP AL,1
+ JA @@2
+ JE @@3
+ TEST AH,AH
+ JNE @@3
+ MOV ECX,[ESI].Integer[4]
+ MOV AH,1
+ JMP @@4
+@@2: PUSH [ESI].Integer[8]
+@@3: PUSH [ESI].Integer[4]
+@@4: ADD ESI,12
+ DEC EDX
+ JNE @@1
+@@5: MOV EDX,[EBX].TEventInfo.Sender
+ MOV EAX,[EBX].TEventInfo.Method.Data
+ CALL [EBX].TEventInfo.Method.Code
+ MOV ESP,EBP
+ POP EBP
+ POP ESI
+ POP EBX
+end;
+
+type
+ PVarArg = ^TVarArg;
+ TVarArg = array[0..3] of DWORD;
+
+function TOleCtl.CreateWindow: Boolean;
+begin
+ Result := FALSE;
+ if fHandle <> 0 then
+ begin
+ Result := TRUE;
+ Exit;
+ end;
+ if fCreatingWnd then
+ Exit;
+ fCreatingWnd := TRUE;
+ try
+ CreateControl;
+ if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
+ begin
+ FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, fOleCtlIntf, 0,
+ ParentWindow, BoundsRect);
+ if FOleInPlaceObject = nil then
+ raise EOleError.CreateResFmt(e_Ole, Integer( @SCannotActivate ), [nil]);
+ HookControlWndProc;
+ if {$IFDEF USE_FLAGS} not(F3_Visible in fStyle.f3_Style)
+ {$ELSE} not fVisible {$ENDIF}
+ and IsWindowVisible(fHandle) then
+ ShowWindow(fHandle, SW_HIDE);
+ Result := TRUE;
+ end
+ else
+ Result := inherited CreateWindow;
+ finally
+ fCreatingWnd := FALSE;
+ end;
+end;
+
+procedure TOleCtl.D2InvokeEvent(DispID: TDispID; var Params: TDispParams);
+type
+ TStringDesc = record
+ PStr: Pointer;
+ BStr: PBStr;
+ end;
+var
+ I, J, K, ArgType, ArgCount, StrCount: Integer;
+ ArgPtr: PEventArg;
+ ParamPtr: PVarArg;
+ Strings: array[0..MaxDispArgs - 1] of TStringDesc;
+ EventInfo: TEventInfo;
+begin
+ fOleCtlIntf.GetEventMethod(DispID, EventInfo.Method);
+ if Integer(EventInfo.Method.Code) >= $10000 then
+ begin
+ StrCount := 0;
+ try
+ ArgCount := Params.cArgs;
+ EventInfo.Sender := fOleCtlIntf;
+ EventInfo.ArgCount := ArgCount;
+ if ArgCount <> 0 then
+ begin
+ ParamPtr := @Params.rgvarg^[EventInfo.ArgCount];
+ ArgPtr := @EventInfo.Args;
+ I := 0;
+ repeat
+ Dec(Integer(ParamPtr), SizeOf(TVarArg));
+ ArgType := ParamPtr^[0] and $0000FFFF;
+ if ArgType and varTypeMask = varOleStr then
+ begin
+ ArgPtr^.Kind := akDWord;
+ with Strings[StrCount] do
+ begin
+ PStr := nil;
+ if ArgType and varByRef <> 0 then
+ begin
+ OleStrToStrVar(PBStr(ParamPtr^[2])^, string(PStr));
+ BStr := PBStr(ParamPtr^[2]);
+ ArgPtr^.Data[0] := Integer(@PStr);
+ end else
+ begin
+ OleStrToStrVar(TBStr(ParamPtr^[2]), string(PStr));
+ BStr := nil;
+ ArgPtr^.Data[0] := Integer(PStr);
+ end;
+ end;
+ Inc(StrCount);
+ end else
+ begin
+ case ArgType of
+ varSingle:
+ begin
+ ArgPtr^.Kind := akSingle;
+ ArgPtr^.Data[0] := ParamPtr^[2];
+ end;
+ varDouble..varDate:
+ begin
+ ArgPtr^.Kind := akDouble;
+ ArgPtr^.Data[0] := ParamPtr^[2];
+ ArgPtr^.Data[1] := ParamPtr^[3];
+ end;
+ varDispatch:
+ begin
+ ArgPtr^.Kind := akDWord;
+ ArgPtr^.Data[0] := Integer(ParamPtr)
+ end;
+ else
+ ArgPtr^.Kind := akDWord;
+ if (ArgType and varArray) <> 0 then
+ ArgPtr^.Data[0] := Integer(ParamPtr)
+ else
+ ArgPtr^.Data[0] := ParamPtr^[2];
+ end;
+ end;
+ Inc(Integer(ArgPtr), SizeOf(TEventArg));
+ Inc(I);
+ until I = EventInfo.ArgCount;
+ end;
+ CallEventMethod(EventInfo);
+ J := StrCount;
+ while J <> 0 do
+ begin
+ Dec(J);
+ with Strings[J] do
+ if BStr <> nil then BStr^ := StringToOleStr(string(PStr));
+ end;
+ except
+ DoHandleException;
+ end;
+ K := StrCount;
+ while K <> 0 do
+ begin
+ Dec(K);
+ string(Strings[K].PStr) := '';
+ end;
+ end;
+end;
+
+procedure TOleCtl.DblClk;
+var MouseData: TMouseEventData;
+ P: TPoint;
+begin
+ {$IFDEF NIL_EVENTS}
+ if Assigned(EV.fOnMouseDblClk) then
+ {$ENDIF}
+ begin
+ MouseData.Button := mbLeft;
+ MouseData.Shift := 0;
+ GetCursorPos( P );
+ P := Screen2Client( P );
+ MouseData.X := P.x;
+ MouseData.Y := P.y;
+ EV.fOnMouseDblClk(@Self, MouseData);
+ end;
+end;
+
+destructor TOleCtl.Destroy;
+
+ procedure FreeList(var L: PList);
+ begin
+ if L = nil then Exit;
+ L.Release;
+ L := nil;
+ end;
+
+begin
+ SetUIActive(False);
+ if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
+ DestroyControl;
+ DestroyStorage;
+ FPersistStream := nil;
+ if FOleObject <> nil then FOleObject.SetClientSite(nil);
+ FOleObject := nil;
+ FEventDispatch.Free;
+ FreeList(FFonts);
+ FreeList(FPictures);
+ Dec(FControlData^.InstanceCount);
+ if FControlData^.InstanceCount = 0 then
+ DestroyEnumPropDescs;
+ fOleCtlIntf.Free;
+ inherited Destroy;
+end;
+
+procedure TOleCtl.DestroyControl;
+begin
+ InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection);
+ InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection);
+ FPropBrowsing := nil;
+ FControlDispatch := nil;
+ FOleControl := nil;
+end;
+
+procedure TOleCtl.DestroyEnumPropDescs;
+var
+ I: Integer;
+begin
+ with FControlData^ do
+ if EnumPropDescs <> nil then
+ begin
+ for I := 0 to EnumPropDescs.Count - 1 do
+ PEnumPropDesc(EnumPropDescs.Items[I]).Free;
+ EnumPropDescs.Free;
+ EnumPropDescs := nil;
+ end;
+end;
+
+procedure TOleCtl.DestroyStorage;
+begin
+ if FObjectData <> 0 then
+ begin
+ GlobalFree(FObjectData);
+ FObjectData := 0;
+ end;
+end;
+
+procedure TOleCtl.DoHandleException;
+begin
+ //Application.HandleException(Self);
+ //TODO: replace Application.HandleException with something
+end;
+
+function TOleCtl.GetByteProp(Index: Integer): Byte;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+function TOleCtl.GetColorProp(Index: Integer): TColor;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+function TOleCtl.GetCompProp(Index: Integer): Comp;
+begin
+ Result := GetDoubleProp(Index);
+end;
+
+function TOleCtl.GetCurrencyProp(Index: Integer): Currency;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VCurrency;
+end;
+
+function TOleCtl.GetDoubleProp(Index: Integer): Double;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VDouble;
+end;
+
+procedure TOleCtlIntf.GetEventMethod(DispID: TDispID; var Method: TMethod);
+{begin // test for D4 - it works...
+ Method.Code := nil;
+ Method.Data := nil;
+end;}
+const
+ szOleCtl = sizeof( TOleCtl );
+asm
+ PUSH EBX
+ PUSH ESI
+ PUSH EDI
+ PUSH ECX
+ MOV EBX,EAX
+ MOV ECX,[EBX].fOleCtl
+ ///////////////////////// fix of events handling
+ MOV EBX, ECX // by Alexey Izyumov
+ ///////////////////////// Octouber, 2001
+ MOV ECX,[ECX].TOleCtl.FControlData
+ MOV EDI,[ECX].TControlData.EventCount
+ MOV ESI,[ECX].TControlData.EventDispIDs
+ XOR EAX,EAX
+ JMP @@1
+@@0: CMP EDX,[ESI].Integer[EAX*4]
+ JE @@2
+ INC EAX
+@@1: CMP EAX,EDI
+ JNE @@0
+ XOR EAX,EAX
+ XOR EDX,EDX
+ JMP @@3
+@@2: PUSH EAX
+ CMP [ECX].TControlData.Version, 401
+ JB @@2a
+ MOV EAX, [ECX].TControlData2.FirstEventOfs
+ TEST EAX, EAX
+ JNE @@2b
+@@2a: {MOV EAX, [EBX]
+ CALL TObject.ClassParent
+ CALL TObject.InstanceSize}
+ MOV EAX, szOleCtl
+ ADD EAX, 7
+ AND EAX, not 7 // 8 byte alignment
+@@2b: ADD EBX, EAX
+ POP EAX
+ MOV EDX,[EBX][EAX*8].TMethod.Data
+ MOV EAX,[EBX][EAX*8].TMethod.Code
+@@3: POP ECX
+ MOV [ECX].TMethod.Code,EAX
+ MOV [ECX].TMethod.Data,EDX
+ POP EDI
+ POP ESI
+ POP EBX
+end;
+
+function TOleCtl.GetEnumPropDesc(DispID: Integer): PEnumPropDesc;
+var
+ I: Integer;
+begin
+ with FControlData^ do
+ begin
+ if EnumPropDescs = nil then CreateEnumPropDescs;
+ for I := 0 to EnumPropDescs.Count - 1 do
+ begin
+ Result := EnumPropDescs.Items[I];
+ if Result.FDispID = DispID then Exit;
+ end;
+ Result := nil;
+ end;
+end;
+
+function TOleCtl.GetIDispatchProp(Index: Integer): IDispatch;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := IDispatch(Temp.VDispatch);
+end;
+
+function TOleCtl.GetIntegerProp(Index: Integer): Integer;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VInteger;
+end;
+
+function TOleCtl.GetIUnknownProp(Index: Integer): IUnknown;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := IUnknown(Temp.VUnknown);
+end;
+
+function TOleCtl.GetMainMenu: HMenu;
+var
+ Form: PControl;
+begin
+ Result := 0;
+ Form := ParentForm;
+ if Form <> nil then
+ //if Form.FormStyle <> fsMDIChild then
+ Result := Form.Menu
+ {else
+ if Application.MainForm <> nil then
+ Result := Application.MainForm.Menu};
+end;
+
+function TOleCtl.GetOleBoolProp(Index: Integer): TOleBool;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VBoolean;
+end;
+
+function TOleCtl.GetOleDateProp(Index: Integer): TOleDate;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VDate;
+end;
+
+function TOleCtl.GetOleEnumProp(Index: Integer): TOleEnum;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+function TOleCtl.GetOleObject: Variant;
+begin
+ CreateControl;
+ Result := Variant(FOleObject as IDispatch);
+end;
+
+function TOleCtl.GetOleVariantProp(Index: Integer): OleVariant;
+begin
+ VarClear(Result);
+ GetProperty(Index, TVarData(Result));
+end;
+
+function TOleCtl.GetOnLeave: TOnEvent;
+begin
+ Result := OnExit;
+end;
+
+var // init to zero, never written to
+ DispParams: TDispParams = ();
+
+procedure TOleCtl.GetProperty(Index: Integer; var Value: TVarData);
+var
+ Status: HResult;
+ ExcepInfo: TExcepInfo;
+begin
+ CreateControl;
+ Value.VType := varEmpty;
+ Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
+ DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil);
+ if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
+end;
+
+function TOleCtl.GetShortIntProp(Index: Integer): ShortInt;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+function TOleCtl.GetSingleProp(Index: Integer): Single;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VSingle;
+end;
+
+function TOleCtl.GetSmallintProp(Index: Integer): Smallint;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VSmallint;
+end;
+
+function TOleCtl.GetStringProp(Index: Integer): string;
+begin
+ Result := GetVariantProp(Index);
+end;
+
+function TOleCtl.GetTColorProp(Index: Integer): TColor;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+function TOleCtl.GetTDateTimeProp(Index: Integer): TDateTime;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VDate;
+end;
+
+function TOleCtl.GetTFontProp(Index: Integer): PGraphicTool;
+{var
+ I: Integer;}
+begin
+ Result := nil;
+ {for I := 0 to FFonts.Count-1 do
+ if FControlData^.FontIDs^[I] = Index then
+ begin
+ Result := TFont(FFonts[I]);
+ if Result.FontAdapter = nil then
+ SetOleFont(Result, GetIDispatchProp(Index) as IFontDisp);
+ end;}
+ //TODO: implement TFont later
+end;
+
+function TOleCtl.GetTOleEnumProp(Index: Integer): TOleEnum;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+function TOleCtl.GetVariantProp(Index: Integer): Variant;
+begin
+ Result := GetOleVariantProp(Index);
+end;
+
+function TOleCtl.GetWideStringProp(Index: Integer): WideString;
+var
+ Temp: TVarData;
+begin
+ Result := '';
+ GetProperty(Index, Temp);
+ Pointer(Result) := Temp.VOleStr;
+end;
+
+function TOleCtl.GetWordBoolProp(Index: Integer): WordBool;
+var
+ Temp: TVarData;
+begin
+ GetProperty(Index, Temp);
+ Result := Temp.VBoolean;
+end;
+
+function TOleCtl.GetWordProp(Index: Integer): Word;
+begin
+ Result := GetIntegerProp(Index);
+end;
+
+procedure TOleCtl.HookControlWndProc;
+var
+ WndHandle: HWnd;
+begin
+ if (FOleInPlaceObject <> nil) and (fHandle = 0) then
+ begin
+ WndHandle := 0;
+ FOleInPlaceObject.GetWindow(WndHandle);
+ if WndHandle = 0 then
+ raise EOleError.CreateResFmt(e_Ole, Integer(@SNoWindowHandle), [nil]);
+ fHandle := WndHandle;
+ fDefWndProc := Pointer(GetWindowLong(fHandle, GWL_WNDPROC));
+ CreatingWindow := @Self;
+ SetWindowLong(fHandle, GWL_WNDPROC, Longint(@WndFunc));
+ SendMessage(fHandle, WM_NULL, 0, 0);
+ end;
+end;
+
+procedure TOleCtl.Init;
+var
+ I: Integer;
+ intfClass: TOleCtlIntfClass;
+begin
+ OleInit;
+ inherited;
+ // overriding this method, we allow for constructor to initialize
+ // the object.
+ fControlClassName := 'OleCtl'; // ClassName
+ {$IFDEF USE_FLAGS} include( fFlagsG3, G3_IsControl );
+ {$ELSE} fIsControl := TRUE; {$ENDIF}
+ fStyle.Value := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
+ WS_CHILD; // or WS_BORDER or WS_THICKFRAME;
+
+ //AttachProc( WndProcCtrl ); for test only
+
+ // The rest of initialization -- moved from OleCtrls
+ InitControlData;
+ Inc(FControlData^.InstanceCount);
+ if FControlData^.FontCount > 0 then
+ begin
+ FFonts := NewList;
+ //FFonts.Count := FControlData^.FontCount;
+ for I := 0 to FControlData^.FontCount-1 do
+ FFonts.Add( NewFont );
+ end;
+ {if FControlData^.PictureCount > 0 then
+ begin
+ FPictures := NewList;
+ //FPictures.Count := FControlData^.PictureCount;
+ for I := 0 to FControlData^.PictureCount-1 do
+ begin
+ FPictures.Add( NewPicture );
+ TPicture(FPictures[I]).OnChange := PictureChanged;
+ end;
+ end;}
+ FEventDispatch := TEventDispatch.Create(@Self);
+ CreateInstance;
+ InitControlInterface(FOleObject);
+ OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus));
+
+ if (Assigned(OnGetIntfClass)) then
+ intfClass := OnGetIntfClass()
+ else
+ intfClass := TOleCtlIntf;
+ fOleCtlIntf := intfClass.Create;
+ fOleCtlIntf.fOleCtl := @Self;
+
+ if (FControlData^.Reserved and cdDeferSetClientSite) = 0 then
+ if ((FMiscStatus and OLEMISC_SETCLIENTSITEFIRST) <> 0) or
+ ((FControlData^.Reserved and cdForceSetClientSite) <> 0) then
+ OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
+ OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream));
+ if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
+ {$IFDEF USE_FLAGS} exclude( fStyle.f3_Style, F3_Visible );
+ {$ELSE} fVisible := False; {$ENDIF}
+ {if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
+ ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else
+ ControlStyle := [csDoubleClicks, csNoStdEvents];}
+ if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then
+ fExStyle := 0; // clear WS_EX_CONTROLPARENT
+ TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or
+ OLEMISC_NOUIACTIVATE) = 0;
+ OleCheck(fOleCtlIntf.RequestNewObjectLayout);
+end;
+
+procedure TOleCtl.InitControlData;
+begin
+ // nothing here. Originally, this method was abstract.
+ // Since TOleControl class became TOleCtl object, abstract methods
+ // are not available. So, make this method empty to override it
+ // in descendant objects, which represent Active-X controls.
+end;
+
+procedure TOleCtl.InitControlInterface(const Obj: IUnknown);
+begin
+ // This method is to override it in derived Active-X control holder.
+end;
+
+procedure TOleCtl.InvokeEvent(DispID: TDispID; var Params: TDispParams);
+var
+ EventMethod: TMethod;
+begin
+ if ControlData.Version < 300 then
+ D2InvokeEvent(DispID, Params)
+ else
+ begin
+ fOleCtlIntf.GetEventMethod(DispID, EventMethod);
+ if Integer(EventMethod.Code) < $10000 then Exit;
+
+ try
+ asm
+ PUSH EBX
+ PUSH ESI
+ MOV ESI, Params
+ MOV EBX, [ESI].TDispParams.cArgs
+ TEST EBX, EBX
+ JZ @@7
+ MOV ESI, [ESI].TDispParams.rgvarg
+ MOV EAX, EBX
+ SHL EAX, 4 // count * sizeof(TVarArg)
+ XOR EDX, EDX
+ ADD ESI, EAX // EDI = Params.rgvarg^[ArgCount]
+ @@1: SUB ESI, 16 // Sizeof(TVarArg)
+ MOV EAX, dword ptr [ESI]
+ CMP AX, varSingle
+ JA @@3
+ JE @@4
+ @@2: TEST DL,DL
+ JNE @@2a
+ MOV ECX, ESI
+ INC DL
+ TEST EAX, varArray
+ JNZ @@6
+ MOV ECX, dword ptr [ESI+8]
+ JMP @@6
+ @@2a: TEST EAX, varArray
+ JZ @@5
+ PUSH ESI
+ JMP @@6
+ @@3: CMP AX, varDate
+ JA @@2
+ @@4: PUSH dword ptr [ESI+12]
+ @@5: PUSH dword ptr [ESI+8]
+ @@6: DEC EBX
+ JNE @@1
+ @@7: MOV EDX, Self
+ MOV EAX, EventMethod.Data
+ CALL EventMethod.Code
+ POP ESI
+ POP EBX
+ end;
+ except
+ DoHandleException;
+ end;
+ end;
+end;
+
+procedure TOleCtl.KeyDown(var Key: Longint; AShift: DWORD);
+begin
+ if Assigned(EV.fOnKeyDown) then EV.fOnKeyDown(@Self, Key, AShift);
+end;
+
+procedure TOleCtl.KeyPress(var Key: KOLChar);
+begin
+ if Assigned(EV.fOnChar) then EV.fOnChar(@Self, Key, 0);
+end;
+
+procedure TOleCtl.KeyUp(var Key: Longint; AShift: DWORD);
+begin
+ if Assigned(EV.fOnKeyUp) then EV.fOnKeyUp(@Self, Key, AShift);
+end;
+
+procedure TOleCtl.MouseDown(Button: TMouseButton; AShift: DWORD; X,
+ Y: Integer);
+begin
+ //TODO: mouse
+end;
+
+procedure TOleCtl.MouseMove(AShift: DWORD; X, Y: Integer);
+begin
+ //TODO: mouse
+end;
+
+procedure TOleCtl.MouseUp(Button: TMouseButton; AShift: DWORD; X,
+ Y: Integer);
+begin
+ //TODO: mouse
+end;
+
+procedure TOleCtl.SetByteProp(Index: Integer; Value: Byte);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.SetColorProp(Index: Integer; Value: TColor);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.SetCompProp(Index: Integer; const Value: Comp);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := VT_I8;
+ Temp.VDouble := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetCurrencyProp(Index: Integer; const Value: Currency);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varCurrency;
+ Temp.VCurrency := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetDoubleProp(Index: Integer; const Value: Double);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varDouble;
+ Temp.VDouble := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetIDispatchProp(Index: Integer; const Value: IDispatch);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varDispatch;
+ Temp.VDispatch := Pointer(Value);
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetIntegerProp(Index, Value: Integer);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varInteger;
+ Temp.VInteger := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetIUnknownProp(Index: Integer; const Value: IUnknown);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := VT_UNKNOWN;
+ Temp.VUnknown := Pointer(Value);
+ SetProperty(Index, Temp);
+end;
+
+(*procedure TOleCtl.SetMouseDblClk(const Value: TOnMouse);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnMouseDblClk := Value;
+end;*)
+
+procedure TOleCtl.SetName(const Value: String);
+var
+ OldName: string;
+ DispID: Integer;
+begin
+ OldName := Name;
+ Name := Value; //inherited SetName(Value);
+ if FOleControl <> nil then
+ begin
+ FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME);
+ if FControlData^.Flags and (cfCaption or cfText) <> 0 then
+ begin
+ if FControlData^.Flags and cfCaption <> 0 then
+ DispID := DISPID_CAPTION else
+ DispID := DISPID_TEXT;
+ if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value);
+ end;
+ end;
+end;
+
+procedure TOleCtl.SetOleBoolProp(Index: Integer; Value: TOleBool);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varBoolean;
+ if Value then
+ Temp.VBoolean := WordBool(-1) else
+ Temp.VBoolean := WordBool(0);
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetOleDateProp(Index: Integer; const Value: TOleDate);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varDate;
+ Temp.VDate := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetOleEnumProp(Index: Integer; Value: TOleEnum);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.SetOleVariantProp(Index: Integer;
+ const Value: OleVariant);
+begin
+ SetProperty(Index, TVarData(Value));
+end;
+
+procedure TOleCtl.SetOnChar(const Value: TOnChar);
+begin
+ {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
+ .fOnChar := Value;
+end;
+
+procedure TOleCtl.SetOnLeave(const Value: TOnEvent);
+begin
+ OnExit := Value;
+end;
+
+procedure TOleCtl.SetParent(AParent: PControl);
+var
+ CS: IOleClientSite;
+ X: Integer;
+begin
+ inherited Parent := AParent;
+ if (AParent <> nil) then
+ begin
+ try // work around ATL bug
+ X := FOleObject.GetClientSite(CS);
+ except
+ X := -1;
+ end;
+ if (X <> 0) or (CS = nil) then
+ OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
+ if FOleControl <> nil then
+ FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN);
+ end;
+end;
+
+procedure TOleCtl.SetProperty(Index: Integer; const Value: TVarData);
+const
+ DispIDArgs: Longint = DISPID_PROPERTYPUT;
+var
+ Status, InvKind: Integer;
+ DispParams: TDispParams;
+ ExcepInfo: TExcepInfo;
+begin
+ CreateControl;
+ DispParams.rgvarg := @Value;
+ DispParams.rgdispidNamedArgs := @DispIDArgs;
+ DispParams.cArgs := 1;
+ DispParams.cNamedArgs := 1;
+ if Value.VType <> varDispatch then
+ InvKind := DISPATCH_PROPERTYPUT else
+ InvKind := DISPATCH_PROPERTYPUTREF;
+ Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
+ InvKind, DispParams, nil, @ExcepInfo, nil);
+ if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
+end;
+
+procedure TOleCtl.SetShortIntProp(Index: Integer; Value: Shortint);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.SetSingleProp(Index: Integer; const Value: Single);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varSingle;
+ Temp.VSingle := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetSmallintProp(Index: Integer; Value: Smallint);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varSmallint;
+ Temp.VSmallint := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetStringProp(Index: Integer; const Value: string);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varOleStr;
+ Temp.VOleStr := StringToOleStr(Value);
+ try
+ SetProperty(Index, Temp);
+ finally
+ SysFreeString(Temp.VOleStr);
+ end;
+end;
+
+procedure TOleCtl.SetTColorProp(Index: Integer; Value: TColor);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.SetTDateTimeProp(Index: Integer; const Value: TDateTime);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varDate;
+ Temp.VDate := Value;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetTFontProp(Index: Integer; Value: PGraphicTool);
+{var
+ I: Integer;
+ F: TFont;
+ Temp: IFontDisp;}
+begin
+ {for I := 0 to FFonts.Count-1 do
+ if FControlData^.FontIDs^[I] = Index then
+ begin
+ F := TFont(FFonts[I]);
+ F.Assign(Value);
+ if F.FontAdapter = nil then
+ begin
+ GetOleFont(F, Temp);
+ SetIDispatchProp(Index, Temp);
+ end;
+ end;}
+ //TODO: implement TFont property later
+end;
+
+procedure TOleCtl.SetTOleEnumProp(Index: Integer; Value: TOleEnum);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.SetUIActive(Active: Boolean);
+var
+ Form: POleCtl; // declare it as POleCtl, though it is only PControl
+ // - to access its protected fields
+begin
+ Form := POleCtl( ParentForm );
+ if Form <> nil then
+ if Active then
+ begin
+ {if (Form.ActiveOleControl <> nil) and
+ (Form.ActiveOleControl <> Self) then
+ Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
+ Form.ActiveOleControl := Self;}
+ if (Form.DF.fCurrentControl <> nil) and
+ (Form.DF.fCurrentControl <> @Self) then
+ Form.DF.fCurrentControl.Perform(CM_UIDEACTIVATE, 0, 0);
+ Form.DF.fCurrentControl := @Self;
+ end else
+ if Form.DF.fCurrentControl = @Self then
+ Form.DF.fCurrentControl := nil;
+end;
+
+procedure TOleCtl.SetVariantProp(Index: Integer; const Value: Variant);
+begin
+ SetOleVariantProp(Index, Value);
+end;
+
+procedure TOleCtl.SetWideStringProp(Index: Integer;
+ const Value: WideString);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varOleStr;
+ if Value <> '' then
+ Temp.VOleStr := PWideChar(Value)
+ else
+ Temp.VOleStr := nil;
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetWordBoolProp(Index: Integer; Value: WordBool);
+var
+ Temp: TVarData;
+begin
+ Temp.VType := varBoolean;
+ if Value then
+ Temp.VBoolean := WordBool(-1) else
+ Temp.VBoolean := WordBool(0);
+ SetProperty(Index, Temp);
+end;
+
+procedure TOleCtl.SetWordProp(Index: Integer; Value: Word);
+begin
+ SetIntegerProp(Index, Value);
+end;
+
+procedure TOleCtl.StandardEvent(DispID: TDispID; var Params: TDispParams);
+type
+ PVarDataList = ^TVarDataList;
+ TVarDataList = array[0..3] of TVarData;
+const
+ {ShiftMap: array[0..7] of TShiftState = (
+ [],
+ [ssShift],
+ [ssCtrl],
+ [ssShift, ssCtrl],
+ [ssAlt],
+ [ssShift, ssAlt],
+ [ssCtrl, ssAlt],
+ [ssShift, ssCtrl, ssAlt]);
+ MouseMap: array[0..7] of TShiftState = (
+ [],
+ [ssLeft],
+ [ssRight],
+ [ssLeft, ssRight],
+ [ssMiddle],
+ [ssLeft, ssMiddle],
+ [ssRight, ssMiddle],
+ [ssLeft, ssRight, ssMiddle]);}
+ ShiftMap: array[0..7] of DWord = (
+ 0,
+ MK_SHIFT,
+ MK_CONTROL,
+ MK_SHIFT or MK_CONTROL,
+ MK_ALT,
+ MK_SHIFT or MK_ALT,
+ MK_CONTROL or MK_ALT,
+ MK_SHIFT or MK_CONTROL or MK_ALT);
+ MouseMap: array[0..7] of DWORD = (
+ 0,
+ MK_LBUTTON,
+ MK_RBUTTON,
+ MK_LBUTTON or MK_RBUTTON,
+ MK_MBUTTON,
+ MK_LBUTTON or MK_MBUTTON,
+ MK_RBUTTON or MK_MBUTTON,
+ MK_LBUTTON or MK_RBUTTON or MK_MBUTTON);
+ ButtonMap: array[0..7] of TMouseButton = (
+ mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft);
+var
+ Args: PVarDataList;
+ AShift: DWORD;
+ Button: TMouseButton;
+ X, Y: Integer;
+ Key: Longint;
+ Ch: KOLChar;
+begin
+ Args := PVarDataList(Params.rgvarg);
+ try
+ case DispID of
+ DISPID_CLICK:
+ Click;
+ DISPID_DBLCLICK:
+ DblClk;
+ DISPID_KEYDOWN, DISPID_KEYUP:
+ if Params.cArgs >= 2 then
+ begin
+ Key := Variant(Args^[1]);
+ X := Variant(Args^[0]);
+ case DispID of
+ DISPID_KEYDOWN: KeyDown(Key, X);
+ DISPID_KEYUP: KeyUp(Key, X);
+ end;
+ if ((Args^[1].vType and varByRef) <> 0) then
+ Word(Args^[1].VPointer^) := Key;
+ end;
+ DISPID_KEYPRESS:
+ if Params.cArgs > 0 then
+ begin
+ Ch := KOLChar(Integer(Variant(Args^[0])));
+ KeyPress(Ch);
+ if ((Args^[0].vType and varByRef) <> 0) then
+ KOLChar(Args^[0].VPointer^) := Ch;
+ end;
+ {DISPID_KEYPRESS:
+ if Params.cArgs > 0 then
+ begin
+ Ch := KOLChar(Integer(Variant(Args^[0])));
+ KeyPress(Ch);
+ if ((Args^[0].vType and varByRef) <> 0) then
+ KOLChar(Args^[0].VPointer^) := Ch;
+ end;}
+ DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP:
+ if Params.cArgs >= 4 then
+ begin
+ X := Integer(Variant(Args^[3])) and 7;
+ Y := Integer(Variant(Args^[2])) and 7;
+ Button := ButtonMap[X];
+ AShift := ShiftMap[Y] + MouseMap[X];
+ X := Variant(Args^[1]);
+ Y := Variant(Args^[0]);
+ case DispID of
+ DISPID_MOUSEDOWN:
+ MouseDown(Button, AShift, X, Y);
+ DISPID_MOUSEMOVE:
+ MouseMove(AShift, X, Y);
+ DISPID_MOUSEUP:
+ MouseUp(Button, AShift, X, Y);
+ end;
+ end;
+ end;
+ except
+ DoHandleException;
+ end;
+end;
+
+{$IFNDEF _D2orD3}
+{ TServerEventDispatch }
+constructor TServerEventDispatch.Create(Server: TOleServer);
+begin
+ FServer := Server;
+ InternalRefCount := 1;
+end;
+
+{ TServerEventDispatch.IUnknown }
+function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then
+ begin
+ Result := S_OK;
+ Exit;
+ end;
+ if IsEqualIID(IID, FServer.FServerData^.EventIID) then
+ begin
+ GetInterface(IDispatch, Obj);
+ Result := S_OK;
+ Exit;
+ end;
+ Result := E_NOINTERFACE;
+end;
+
+function TServerEventDispatch._AddRef: Integer;
+begin
+ if FServer <> nil then FServer._AddRef;
+ InternalRefCount := InternalRefCount + 1;
+ Result := InternalRefCount;
+end;
+
+function TServerEventDispatch._Release: Integer;
+begin
+ if FServer <> nil then FServer._Release;
+ InternalRefCount := InternalRefCount -1;
+ Result := InternalRefCount;
+end;
+
+{ TServerEventDispatch.IDispatch }
+function TServerEventDispatch.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+ Count := 0;
+ Result:= S_OK;
+end;
+
+function TServerEventDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
+begin
+ Pointer(TypeInfo) := nil;
+ Result := E_NOTIMPL;
+end;
+
+function TServerEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TServerEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
+ LocaleID: Integer; Flags: Word; var Params;
+ VarResult, ExcepInfo, ArgErr: Pointer): HResult;
+var
+ ParamCount, I: integer;
+ VarArray : TVariantArray;
+begin
+ // Get parameter count
+ ParamCount := TDispParams(Params).cArgs;
+ // Set our array to appropriate length
+ SetLength(VarArray, ParamCount);
+ // Copy over data
+ for I := Low(VarArray) to High(VarArray) do
+ VarArray[High(VarArray)-I] := OleVariant(TDispParams(Params).rgvarg^[I]);
+ // Invoke Server proxy class
+ if FServer <> nil then FServer.InvokeEvent(DispID, VarArray);
+ // Clean array
+ SetLength(VarArray, 0);
+ // Pascal Events return 'void' - so assume success!
+ Result := S_OK;
+end;
+
+function TServerEventDispatch.ServerDisconnect : Boolean;
+begin
+ FServer := nil;
+ if FServer <> nil then
+ Result := false
+ else Result := true;
+end;
+
+{TOleServer}
+constructor TOleServer.Create; //(AOwner: TComponent);
+begin
+ inherited; // Create(AOwner);
+ // Allow derived class to initialize ServerData structure pointer
+ InitServerData;
+ // Make sure derived class set ServerData pointer to some valid structure
+ Assert(FServerData <> nil);
+ // Increment instance count (not used currently)
+ Inc(FServerData^.InstanceCount);
+ // Create Event Dispatch Handler
+ FEventDispatch := TServerEventDispatch.Create(Self);
+end;
+
+destructor TOleServer.Destroy;
+begin
+ // Disconnect from the Server (NOTE: Disconnect must handle case when we're no longer connected)
+ Disconnect;
+ // Free Events dispatcher
+ FEventDispatch.ServerDisconnect;
+ if (FEventDispatch._Release = 0) then FEventDispatch.Free;
+ // Decrement refcount
+ Dec(FServerData^.InstanceCount);
+ inherited Destroy;
+end;
+
+procedure TOleServer.Loaded;
+begin
+ {inherited Loaded;}
+
+ // Load Server if user requested 'AutoConnect' and we're not in Design mode
+ {if not (csDesigning in ComponentState) then}
+ if AutoConnect then
+ Connect;
+end;
+
+procedure TOleServer.InvokeEvent(DispID: TDispID; var Params: TVariantArray);
+begin
+ // To be overriden in derived classes to do dispatching
+end;
+
+function TOleServer.GetServer: IUnknown;
+var
+ HR: HResult;
+ ErrorStr: string;
+begin
+ case ConnectKind of
+ ckNewInstance:
+ Result := CreateComObject(FServerData^.ClassId);
+
+ ckRunningInstance:
+ begin
+ HR := GetActiveObject(FServerData^.ClassId, nil, Result);
+ if not Succeeded(HR) then
+ begin
+ ErrorStr := Format(sNoRunningObject, [ClassIDToProgID(FServerData^.ClassId),
+ GuidToString(FServerData^.ClassId)]);
+ raise EOleSysError.Create( e_Ole, ErrorStr {, HR, 0} );
+ end;
+ end;
+
+ ckRunningOrNew:
+ if not Succeeded(GetActiveObject(FServerData^.ClassId, nil, Result)) then
+ Result := CreateComObject(FServerData^.ClassId);
+
+ ckRemote:
+ {Highly inefficient: requires at least two round trips - GetClassObject + QI}
+ Result := CreateRemoteComObject(RemoteMachineName, FServerData^.ClassID);
+ end;
+end;
+
+procedure TOleServer.ConnectEvents(const Obj: IUnknown);
+begin
+ KOLComObj.InterfaceConnect(Obj, FServerData^.EventIID, FEventDispatch, FEventsConnection);
+end;
+
+procedure TOleServer.DisconnectEvents(const Obj: Iunknown);
+begin
+ KOLComObj.InterfaceDisconnect(Obj, FServerData^.EventIID, FEventsConnection);
+end;
+
+function TOleServer.GetConnectKind: TConnectKind;
+begin
+ // Should the setting of a RemoteMachine name override the Connection Kind ??
+ if RemoteMachineName <> '' then
+ Result := ckRemote
+ else
+ Result := FConnectKind;
+end;
+
+procedure TOleServer.SetConnectKind(cK: TConnectKind);
+begin
+ // Should we validate that we have a RemoteMachineName for ckRemote ??
+ FConnectKind := cK;
+end;
+
+function TOleServer.GetAutoConnect: Boolean;
+begin
+ // If user wants to provide the interface to connect to, then we won't
+ // 'automatically' connect to a server.
+ if ConnectKind = ckAttachToInterface then
+ Result := False
+ else
+ Result := FAutoConnect;
+end;
+
+procedure TOleServer.SetAutoConnect(flag: Boolean);
+begin
+ FAutoConnect := flag;
+end;
+
+{ TOleServer.IUnknown }
+function TOleServer.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then
+ Result := S_OK
+ else
+ Result := E_NOINTERFACE;
+end;
+
+function TOleServer._AddRef: Integer;
+begin
+ Inc(FRefCount);
+ Result := FRefCount;
+end;
+
+function TOleServer._Release: Integer;
+begin
+ Dec(FRefCount);
+ Result := FRefCount;
+end;
+{$ENDIF _D2orD3}
+
+{ TEventDispatch }
+
+constructor TEventDispatch.Create(Control: POleCtl);
+begin
+ FControl := Control;
+end;
+
+{ TEventDispatch.IUnknown }
+
+function TEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then
+ begin
+ Result := S_OK;
+ Exit;
+ end;
+ if IsEqualIID(IID, FControl.FControlData^.EventIID) then
+ begin
+ GetInterface(IDispatch, Obj);
+ Result := S_OK;
+ Exit;
+ end;
+ Result := E_NOINTERFACE;
+end;
+
+function TEventDispatch._AddRef: Integer;
+begin
+ Result := FControl.fOleCtlIntf._AddRef;
+end;
+
+function TEventDispatch._Release: Integer;
+begin
+ Result := FControl.fOleCtlIntf._Release;
+end;
+
+{ TEventDispatch.IDispatch }
+
+function TEventDispatch.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+ Count := 0;
+ Result := S_OK;
+end;
+
+function TEventDispatch.GetTypeInfo(Index, LocaleID: Integer;
+ out TypeInfo): HResult;
+begin
+ Pointer(TypeInfo) := nil;
+ Result := E_NOTIMPL;
+end;
+
+function TEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TEventDispatch.Invoke(DispID: Integer; const IID: TGUID;
+ LocaleID: Integer; Flags: Word; var Params;
+ VarResult, ExcepInfo, ArgErr: Pointer): HResult;
+begin
+ if (DispID >= DISPID_MOUSEUP) and (DispID <= DISPID_CLICK) then
+ FControl.StandardEvent(DispID, TDispParams(Params)) else
+ FControl.InvokeEvent(DispID, TDispParams(Params));
+ Result := S_OK;
+end;
+
+{ TOleCtlIntf }
+
+function TOleCtlIntf._AddRef: Integer;
+begin
+ //{$IFDEF _D2orD3}
+ //Result := inherited _AddRef;
+ //{$ELSE}
+ Inc(FRefCount);
+ Result := FRefCount;
+ //{$ENDIF}
+end;
+
+function TOleCtlIntf._Release: Integer;
+begin
+ //{$IFDEF _D2orD3}
+ //Result := inherited _Release;
+ //{$ELSE}
+ Dec(FRefCount);
+ Result := FRefCount;
+ //{$ENDIF}
+end;
+
+function TOleCtlIntf.CanInPlaceActivate: HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.DeactivateAndUndo: HResult;
+begin
+ fOleCtl.FOleInPlaceObject.UIDeactivate;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.DiscardUndoState: HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.EnableModeless(fEnable: BOOL): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.GetBorder(out rectBorder: TRect): HResult;
+begin
+ Result := INPLACE_E_NOTOOLSPACE;
+end;
+
+function TOleCtlIntf.GetContainer(out container: IOleContainer): HResult;
+begin
+ Result := E_NOINTERFACE;
+end;
+
+function TOleCtlIntf.GetExtendedControl(out disp: IDispatch): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.GetIDsOfNames(const IID: TGUID; Names: Pointer;
+ NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.GetMoniker(dwAssign, dwWhichMoniker: Integer;
+ out mk: IMoniker): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.GetTypeInfo(Index, LocaleID: Integer;
+ out TypeInfo): HResult;
+begin
+ Pointer(TypeInfo) := nil;
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.GetTypeInfoCount(out Count: Integer): HResult;
+begin
+ Count := 0;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.GetWindowContext(out frame: IOleInPlaceFrame;
+ out doc: IOleInPlaceUIWindow; out rcPosRect, rcClipRect: TRect;
+ out frameInfo: TOleInPlaceFrameInfo): HResult;
+begin
+ frame := Self;
+ doc := nil;
+ rcPosRect := fOleCtl.BoundsRect;
+ rcClipRect := MakeRect( 0, 0, 32767, 32767 );
+ with frameInfo do
+ begin
+ fMDIApp := False;
+ hWndFrame := fOleCtl.ParentForm.GetWindowHandle;
+ //GetTopParentHandle;
+ // now it is not possible to make alien window to be parent for KOL window
+ hAccel := 0;
+ cAccelEntries := 0;
+ end;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.InsertMenus(hmenuShared: HMenu;
+ var menuWidths: TOleMenuGroupWidths): HResult;
+{var
+ Menu: TMainMenu;}
+begin
+ {Menu := GetMainMenu;
+ if Menu <> nil then
+ Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);}
+ //TODO: implement menu populate
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.Invoke(DispID: Integer; const IID: TGUID;
+ LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
+ ArgErr: Pointer): HResult;
+{var
+ F: PGraphicTool;}
+begin
+ if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
+ begin
+ Result := S_OK;
+ case DispID of
+ DISPID_AMBIENT_BACKCOLOR:
+ PVariant(VarResult)^ := fOleCtl.Color;
+ DISPID_AMBIENT_DISPLAYNAME:
+ PVariant(VarResult)^ := StringToVarOleStr( fOleCtl.Name );
+ DISPID_AMBIENT_FONT:
+ begin
+ {if (fOleCtl.Parent <> nil) and fOleCtl.ParentFont then
+ F := Parent.Font // TOleControl(Parent).Font
+ else
+ F := Font;
+ PVariant(VarResult)^ := FontToOleFont(F);}
+ //TODO: implement Font later
+ end;
+ DISPID_AMBIENT_FORECOLOR:
+ PVariant(VarResult)^ := fOleCtl.fTextColor; // Font.Color;
+ DISPID_AMBIENT_LOCALEID:
+ PVariant(VarResult)^ := Integer(GetUserDefaultLCID);
+ DISPID_AMBIENT_MESSAGEREFLECT:
+ PVariant(VarResult)^ := True;
+ DISPID_AMBIENT_USERMODE:
+ PVariant(VarResult)^ := TRUE; // not (csDesigning in ComponentState);
+ DISPID_AMBIENT_UIDEAD:
+ PVariant(VarResult)^ := FALSE; // csDesigning in ComponentState;
+ DISPID_AMBIENT_SHOWGRABHANDLES:
+ PVariant(VarResult)^ := False;
+ DISPID_AMBIENT_SHOWHATCHING:
+ PVariant(VarResult)^ := False;
+ DISPID_AMBIENT_SUPPORTSMNEMONICS:
+ PVariant(VarResult)^ := True;
+ DISPID_AMBIENT_AUTOCLIP:
+ PVariant(VarResult)^ := True;
+ else
+ Result := DISP_E_MEMBERNOTFOUND;
+ end;
+ end else
+ Result := DISP_E_MEMBERNOTFOUND;
+end;
+
+function TOleCtlIntf.LockInPlaceActive(fLock: BOOL): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.OleControlSite_TranslateAccelerator(msg: PMsg;
+ grfModifiers: Integer): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult;
+begin
+ wnd := fOleCtl.ParentForm.GetWindowHandle; // GetTopParentHandle;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OleInPlaceFrame_TranslateAccelerator(var msg: Windows.TMsg;
+ wID: Word): HResult;
+begin
+ Result := S_FALSE;
+end;
+
+function TOleCtlIntf.OleInPlaceSite_GetWindow(out wnd: HWnd): HResult;
+begin
+ Result := S_OK;
+ wnd := fOleCtl.ParentWindow;
+ if wnd = 0 then Result := E_FAIL;
+end;
+
+function TOleCtlIntf.OnChanged(dispid: TDispID): HResult;
+begin
+ try
+ case dispid of
+ DISPID_BACKCOLOR:
+ if not fOleCtl.FUpdatingColor then
+ begin
+ fOleCtl.FUpdatingColor := True;
+ try
+ fOleCtl.fColor := fOleCtl.GetIntegerProp(DISPID_BACKCOLOR);
+ finally
+ fOleCtl.FUpdatingColor := False;
+ end;
+ end;
+ DISPID_ENABLED:
+ if not fOleCtl.FUpdatingEnabled then
+ begin
+ fOleCtl.FUpdatingEnabled := True;
+ try
+ fOleCtl.Enabled := fOleCtl.GetWordBoolProp(DISPID_ENABLED);
+ finally
+ fOleCtl.FUpdatingEnabled := False;
+ end;
+ end;
+ DISPID_FONT:
+ if not fOleCtl.FUpdatingFont then
+ begin
+ fOleCtl.FUpdatingFont := True;
+ try
+ //OleFontToFont(GetVariantProp(DISPID_FONT), Font);
+ // font - implement later
+ finally
+ fOleCtl.FUpdatingFont := False;
+ end;
+ end;
+ DISPID_FORECOLOR:
+ if not fOleCtl.FUpdatingFont then
+ begin
+ fOleCtl.FUpdatingFont := True;
+ try
+ fOleCtl.fTextColor := fOleCtl.GetIntegerProp(DISPID_FORECOLOR);
+ //Font.Color := GetIntegerProp(DISPID_FORECOLOR);
+ finally
+ fOleCtl.FUpdatingFont := False;
+ end;
+ end;
+ end;
+ except // control sent us a notification for a dispid it doesn't have.
+ //on EOleError do ;
+ end;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnControlInfoChanged: HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.OnFocus(fGotFocus: BOOL): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.OnInPlaceActivate: HResult;
+begin
+ fOleCtl.FOleObject.QueryInterface( IOleInPlaceObject,
+ fOleCtl.FOleInPlaceObject);
+ fOleCtl.FOleObject.QueryInterface( IOleInPlaceActiveObject,
+ fOleCtl.FOleInPlaceActiveObject);
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnInPlaceDeactivate: HResult;
+begin
+ fOleCtl.FOleInPlaceActiveObject := nil;
+ fOleCtl.FOleInPlaceObject := nil;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnPosRectChange(const rcPosRect: TRect): HResult;
+begin
+ fOleCtl.FOleInPlaceObject.SetObjectRects(rcPosRect, MakeRect(0, 0, 32767, 32767));
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnRequestEdit(dispid: TDispID): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnShowWindow(fShow: BOOL): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnUIActivate: HResult;
+begin
+ fOleCtl.SetUIActive(True);
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.OnUIDeactivate(fUndoable: BOOL): HResult;
+begin
+ SetMenu(0, 0, 0);
+ fOleCtl.SetUIActive(False);
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
+ out res: Integer; Cookie: Integer): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
+ out res, Cookie: Integer): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.QueryInterface(const IID: TGUID; out Obj): HResult;
+begin
+ if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
+end;
+
+function TOleCtlIntf.RemoveMenus(hmenuShared: HMenu): HResult;
+begin
+ while GetMenuItemCount(hmenuShared) > 0 do
+ RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.RequestBorderSpace(
+ const borderwidths: TRect): HResult;
+begin
+ Result := INPLACE_E_NOTOOLSPACE;
+end;
+
+function TOleCtlIntf.RequestNewObjectLayout: HResult;
+var
+ Extent: TPoint;
+ W, H: Integer;
+ DC: HDC;
+ PixelsPerInch: Integer;
+begin
+ Result := fOleCtl.FOleObject.GetExtent(DVASPECT_CONTENT, Extent);
+ if Result <> S_OK then Exit;
+
+ W := fOleCtl.Width;
+ H := fOleCtl.Height;
+ if (W = 0) or (H = 0) then
+ begin
+ DC := GetDC(0);
+ PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
+ ReleaseDC(0, DC);
+
+ W := MulDiv(Extent.X, PixelsPerInch, 2540);
+ H := MulDiv(Extent.Y, PixelsPerInch, 2540);
+ if (fOleCtl.FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) and
+ (fOleCtl.FOleControl = nil) then
+ begin
+ if W > 32 then W := 32;
+ if H > 32 then H := 32;
+ end;
+ end;
+ fOleCtl.SetBoundsRect( MakeRect( fOleCtl.Left, fOleCtl.Top,
+ fOleCtl.Left + W, fOleCtl.Top + H ) );
+end;
+
+function TOleCtlIntf.SaveObject: HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.Scroll(scrollExtent: TPoint): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.SetActiveObject(
+ const activeObject: IOleInPlaceActiveObject;
+ pszObjName: POleStr): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.SetBorderSpace(pborderwidths: PRect): HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.SetMenu(hmenuShared, holemenu: HMenu;
+ hwndActiveObject: HWnd): HResult;
+var
+ Menu: HMenu;
+begin
+ Menu := fOleCtl.GetMainMenu;
+ Result := S_OK;
+ if Menu <> 0 then
+ begin
+ //Menu.SetOle2MenuHandle(hmenuShared);
+ Result := OleSetMenuDescriptor( holemenu,
+ fOleCtl.ParentForm.GetWindowHandle,
+ hwndActiveObject, nil, nil);
+ end;
+end;
+
+function TOleCtlIntf.SetStatusText(pszStatusText: POleStr): HResult;
+begin
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.ShowObject: HResult;
+begin
+ fOleCtl.HookControlWndProc;
+ Result := S_OK;
+end;
+
+function TOleCtlIntf.ShowPropertyFrame: HResult;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TOleCtlIntf.TransformCoords(var ptlHimetric: TPoint;
+ var ptfContainer: TPointF; flags: Integer): HResult;
+var DC: HDC;
+ PixelsPerInch: Integer;
+begin
+ DC := GetDC(0);
+ PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);
+ ReleaseDC(0, DC);
+
+ if flags and XFORMCOORDS_HIMETRICTOCONTAINER <> 0 then
+ begin
+ ptfContainer.X := MulDiv(ptlHimetric.X, PixelsPerInch, 2540);
+ ptfContainer.Y := MulDiv(ptlHimetric.Y, PixelsPerInch, 2540);
+ end else
+ begin
+ ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / PixelsPerInch));
+ ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / PixelsPerInch));
+ end;
+ Result := S_OK;
+end;
+
+constructor TOleCtlIntf.Create;
+begin
+ inherited;
+end;
+
+
+end.
|