← Back to branch summary

~ubuntu-branches/ubuntu/vivid/lazarus/vivid

« back to all changes in this revision

Viewing changes to components/activex/activexcontainer.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Paul Gevers
  • Date: 2014-02-22 10:25:57 UTC
  • mfrom: (1.1.11)
  • Revision ID: package-import@ubuntu.com-20140222102557-ors9d31r84nz31jq
Tags: 1.2~rc2+dfsg-1
http://bugs.debian.org/724776
[ Abou Al Montacir ]
* New upstream pre-release.
  + Moved ideintf to components directory.
  + Added new package cairocanvas.
* Remove usage of depreciated parameters form of find. (Closes: Bug#724776)
* Bumped standard version to 3.9.5.
* Clean the way handling make files generation and removal.

[ Paul Gevers ]
* Remove nearly obsolete bzip compression for binary packages
  (See https://lists.debian.org/debian-devel/2014/01/msg00542.html)
* Update d/copyright for newly added dir in examples and components
* Update Vcs-* fields with new packaging location
* Update d/watch file to properly (Debian way) change upstreams versions
* Prevent 46MB of package size by sym linking duplicate files
* Patches
  - refresh to remove fuzz
  - add more Lintian found spelling errors
  - new patch to add shbang to two scripts in lazarus-src
* Drop lcl-# from Provides list of lcl-units-#
* Make lazarus-ide-qt4-# an arch all until it really contains stuff
* Make all metapackages arch all as the usecase for arch any doesn't
  seem to warrant the addition archive hit
* Fix permissions of non-scripts in lazarus-src-#

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/activex/activexcontainer.pas
 
1
unit activexcontainer;
 
2
 
 
3
{$mode delphi}{$H+}
 
4
 
 
5
{ Visual ActiveX container.
 
6
 
 
7
  Copyright (C) 2011 Ludo Brands
 
8
 
 
9
  This library is free software; you can redistribute it and/or modify it
 
10
  under the terms of the GNU Library General Public License as published by
 
11
  the Free Software Foundation; either version 2 of the License, or (at your
 
12
  option) any later version with the following modification:
 
13
 
 
14
  As a special exception, the copyright holders of this library give you
 
15
  permission to link this library with independent modules to produce an
 
16
  executable, regardless of the license terms of these independent modules,and
 
17
  to copy and distribute the resulting executable under terms of your choice,
 
18
  provided that you also meet, for each linked independent module, the terms
 
19
  and conditions of the license of that module. An independent module is a
 
20
  module which is not derived from or based on this library. If you modify
 
21
  this library, you may extend this exception to your version of the library,
 
22
  but you are not obligated to do so. If you do not wish to do so, delete this
 
23
  exception statement from your version.
 
24
 
 
25
  This program is distributed in the hope that it will be useful, but WITHOUT
 
26
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
27
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
 
28
  for more details.
 
29
 
 
30
  You should have received a copy of the GNU Library General Public License
 
31
  along with this library; if not, write to the Free Software Foundation,
 
32
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
33
}
 
34
 
 
35
interface
 
36
 
 
37
uses
 
38
  Classes, SysUtils, Controls, Windows, ActiveX, ComObj, Forms, Graphics;
 
39
 
 
40
type
 
41
  //from OCIDL.h
 
42
  PPointF = ^TPointF;
 
43
  tagPOINTF = record
 
44
    x: Single;
 
45
    y: Single;
 
46
  end;
 
47
  TPointF = tagPOINTF;
 
48
  POINTF = TPointF;
 
49
 
 
50
 
 
51
  IOleControlSite = interface
 
52
    ['{B196B289-BAB4-101A-B69C-00AA00341D07}']
 
53
    function OnControlInfoChanged: HResult; stdcall;
 
54
    function LockInPlaceActive(fLock: BOOL): HResult; stdcall;
 
55
    function GetExtendedControl(out disp: IDispatch): HResult; stdcall;
 
56
    function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
 
57
      flags: Longint): HResult; stdcall;
 
58
    function TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;
 
59
       stdcall;
 
60
    function OnFocus(fGotFocus: BOOL): HResult; stdcall;
 
61
    function ShowPropertyFrame: HResult; stdcall;
 
62
  end;
 
63
 
 
64
  IPropertyNotifySink = interface
 
65
    ['{9BFBBC02-EFF1-101A-84ED-00AA00341D07}']
 
66
    function OnChanged(dispid: TDispID): HResult; stdcall;
 
67
    function OnRequestEdit(dispid: TDispID): HResult; stdcall;
 
68
  end;
 
69
 
 
70
  ISimpleFrameSite = interface
 
71
    ['{742B0E01-14E6-101B-914E-00AA00300CAB}']
 
72
    function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
 
73
      out res: Integer; out Cookie: Longint): HResult;
 
74
      stdcall;
 
75
    function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
 
76
      out res: Integer; Cookie: Longint): HResult;
 
77
      stdcall;
 
78
  end;
 
79
 
 
80
 
 
81
  TStatusTextEvent = procedure(Sender: TObject; Status:string) of object;
 
82
 
 
83
  { TActiveXContainer }
 
84
 
 
85
  TActiveXContainer = class(TWinControl, IUnknown, IOleClientSite,
 
86
    IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch)
 
87
    private
 
88
      FActive: boolean;
 
89
      FAttached: boolean;
 
90
      FClassName: string;
 
91
      FOleObject: IDispatch;
 
92
      FOnStatusText: TStatusTextEvent;
 
93
      FPrevWndProc:windows.WNDPROC;
 
94
      Function GetvObject:variant;
 
95
      //IOleClientSite
 
96
      Function SaveObject: HResult;StdCall;
 
97
      Function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;OUT mk: IMoniker):HResult;StdCall;
 
98
      Function GetContainer(OUT container: IOleContainer):HResult;StdCall;
 
99
      procedure SetActive(AValue: boolean);
 
100
      procedure SetClassName(AValue: string);
 
101
      procedure SetOleObject(AValue: IDispatch);
 
102
      Function ShowObject:HResult;StdCall;
 
103
      Function OnShowWindow(fShow: BOOL):HResult;StdCall;
 
104
      Function RequestNewObjectLayout:HResult;StdCall;
 
105
      //IOleControlSite
 
106
      function OnControlInfoChanged: HResult; stdcall;
 
107
      function LockInPlaceActive(fLock: BOOL): HResult; stdcall;
 
108
      function GetExtendedControl(out disp: IDispatch): HResult; stdcall;
 
109
      function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
 
110
        flags: Longint): HResult; stdcall;
 
111
      function TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;overload;
 
112
         stdcall;
 
113
      function OnFocus(fGotFocus: BOOL): HResult; stdcall;
 
114
      function ShowPropertyFrame: HResult; stdcall;
 
115
      //IOleInPlaceSite
 
116
      function CanInPlaceActivate : HResult;stdcall;
 
117
      function OnInPlaceActivate : HResult;stdcall;
 
118
      function OnUIActivate : HResult;stdcall;
 
119
      function GetWindowContext(out ppframe:IOleInPlaceFrame;out ppdoc:IOleInPlaceUIWindow;lprcposrect:LPRECT;lprccliprect:LPRECT;lpframeinfo:LPOLEINPLACEFRAMEINFO):hresult; stdcall;
 
120
      function Scroll(scrollExtant:TSIZE):hresult; stdcall;
 
121
      function OnUIDeactivate(fUndoable:BOOL):hresult; stdcall;
 
122
      function OnInPlaceDeactivate :hresult; stdcall;
 
123
      function DiscardUndoState :hresult; stdcall;
 
124
      function DeactivateAndUndo :hresult; stdcall;
 
125
      function OnPosRectChange(lprcPosRect:LPRect):hresult; stdcall;
 
126
      //IOleWindow
 
127
      function GetWindow(out wnd: HWnd): HResult; stdcall;
 
128
      function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
 
129
       //IOleInPlaceFrame
 
130
      function InsertMenus(hmenuShared: HMenu; var menuWidths: TOleMenuGroupWidths): HResult;StdCall;
 
131
      function SetMenu(hmenuShared: HMenu; holemenu: HMenu; hwndActiveObject: HWnd): HResult;StdCall;
 
132
      function RemoveMenus(hmenuShared: HMenu): HResult;StdCall;
 
133
      function SetStatusText(pszStatusText: POleStr): HResult;StdCall;
 
134
      function EnableModeless(fEnable: BOOL): HResult;StdCall;
 
135
      function TranslateAccelerator(var msg: TMsg; wID: Word): HResult;StdCall;overload;
 
136
      //IOleInPlaceUIWindow
 
137
      function GetBorder(out rectBorder: TRect):HResult;StdCall;
 
138
      function RequestBorderSpace(const borderwidths: TRect):HResult;StdCall;
 
139
      function SetBorderSpace(const borderwidths: TRect):HResult;StdCall;
 
140
      function SetActiveObject(const activeObject: IOleInPlaceActiveObject;pszObjName: POleStr):HResult;StdCall;
 
141
      //IDispatch
 
142
      function GetTypeInfoCount(out count : longint) : HResult;stdcall;
 
143
      function GetTypeInfo(Index,LocaleID : longint;
 
144
        out TypeInfo): HResult;stdcall;
 
145
      function GetIDsOfNames(const iid: TGUID; names: Pointer;
 
146
        NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
 
147
      function Invoke(DispID: LongInt;const iid : TGUID;
 
148
            LocaleID : longint; Flags: Word;var params;
 
149
            VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
 
150
      //internal
 
151
      procedure Attach;
 
152
      procedure Detach;
 
153
   public
 
154
      constructor Create(TheOwner: TComponent); override;
 
155
      destructor Destroy; override;
 
156
      //VT_DISPATCH variant used for late binding
 
157
      property vObject:Variant read GetvObject;
 
158
   published
 
159
      property Align;
 
160
      property Anchors;
 
161
      property AutoSize;
 
162
      property BorderSpacing;
 
163
      property ChildSizing;
 
164
      //ActiveX object is automatically created from classname and destroyed when set
 
165
      property OleClassName:string read FClassName write SetClassName;
 
166
      property ClientHeight;
 
167
      property ClientWidth;
 
168
      property Constraints;
 
169
      property DockSite;
 
170
      property DragCursor;
 
171
      property DragKind;
 
172
      property DragMode;
 
173
      property Enabled;
 
174
      {IDispatch interface for ActiveX object. Overrides classname. Set ComServer
 
175
      when you create and destroy the object yourself, fe. using CoClass.
 
176
      When Active, returns the IDispatch for the object.
 
177
      }
 
178
      property ComServer:IDispatch read FOleObject write SetOleObject;
 
179
      property ParentShowHint;
 
180
      property PopupMenu;
 
181
      property ShowHint;
 
182
      property TabOrder;
 
183
      property TabStop;
 
184
      property UseDockManager default True;
 
185
      property Visible;
 
186
      property OnDockDrop;
 
187
      property OnDockOver;
 
188
      property OnDragDrop;
 
189
      property OnDragOver;
 
190
      property OnEndDock;
 
191
      property OnEndDrag;
 
192
      property OnEnter;
 
193
      property OnExit;
 
194
      property OnGetSiteInfo;
 
195
      property OnGetDockCaption;
 
196
      property OnResize;
 
197
      property OnStartDock;
 
198
      property OnStartDrag;
 
199
      property OnStatusText:TStatusTextEvent read FOnStatusText write FOnStatusText;
 
200
      property OnUnDock;
 
201
      {When set, binds ActiveX component to control.
 
202
      When cleared, detaches the component from the control
 
203
      If Classname is provided the ActiveX component will also be created and destroyed
 
204
      automatically.}
 
205
      property Active:boolean read FActive write SetActive;
 
206
    end;
 
207
 
 
208
implementation
 
209
 
 
210
{$ifdef wince}
 
211
const
 
212
  GWLP_USERDATA=GWL_USERDATA;
 
213
 
 
214
function GetWindowLongPtrW(hWnd:HWND; nIndex:longint):LONG;
 
215
begin
 
216
  result:=GetWindowLongW(hWnd, nIndex);
 
217
end;
 
218
 
 
219
function SetWindowLongPtrW(hWnd:HWND; nIndex:longint; dwNewLong:LONG):LONG;
 
220
begin
 
221
  result:=SetWindowLongW(hWnd, nIndex, dwNewLong);
 
222
end;
 
223
 
 
224
function SetWindowLongPtr(hWnd:HWND; nIndex:longint; dwNewLong:LONG):LONG;
 
225
begin
 
226
  result:=SetWindowLongW(hWnd, nIndex, dwNewLong);
 
227
end;
 
228
{$endif wince}
 
229
 
 
230
function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam;
 
231
  lParam: LParam): LRESULT; stdcall;
 
232
  var
 
233
    bounds:TRect;
 
234
    DC: HDC;
 
235
    size:TPOINT;
 
236
    AXC:TActiveXContainer;
 
237
begin
 
238
  AXC:=TActiveXContainer(GetWindowLongPtrW( Ahwnd, GWLP_USERDATA));
 
239
  case uMsg of
 
240
    WM_DESTROY:AXC.Detach;
 
241
    WM_SIZE:
 
242
      begin
 
243
      size.x:=(LOWORD(lparam)*2540) div Screen.PixelsPerInch;
 
244
      size.y:=(HIWORD(lparam)*2540) div Screen.PixelsPerInch;
 
245
      AXC.Width:=LOWORD(lparam);
 
246
      AXC.Height:=HIWORD(lparam);
 
247
      olecheck((AXC.ComServer as IOleObject).SetExtent(DVASPECT_CONTENT,size));
 
248
      bounds:=AXC.ClientRect;
 
249
      olecheck((AXC.ComServer as IOleInPlaceObject).SetObjectRects(@bounds,@bounds));
 
250
      end;
 
251
    WM_PAINT:
 
252
       begin
 
253
       DC:=GetDC(AXC.handle);
 
254
       bounds:=AXC.ClientRect;
 
255
       olecheck((AXC.ComServer as IViewObject).Draw(DVASPECT_CONTENT,0,nil,nil,0,DC,@bounds,@bounds,nil,0));
 
256
       ReleaseDC(AXC.handle,DC);
 
257
      end;
 
258
  end;
 
259
  result:=CallWindowProc(AXC.FPrevWndProc,Ahwnd, uMsg, WParam, LParam);
 
260
end;
 
261
 
 
262
{ TActiveXContainer }
 
263
 
 
264
function TActiveXContainer.GetvObject: variant;
 
265
begin
 
266
  result:=FOleObject;
 
267
end;
 
268
 
 
269
function TActiveXContainer.SaveObject: HResult; StdCall;
 
270
begin
 
271
  Result := S_OK;
 
272
end;
 
273
 
 
274
function TActiveXContainer.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; out
 
275
  mk: IMoniker): HResult; StdCall;
 
276
begin
 
277
  mk := nil;
 
278
  Result := E_NOTIMPL;
 
279
end;
 
280
 
 
281
function TActiveXContainer.GetContainer(out container: IOleContainer): HResult;
 
282
  StdCall;
 
283
begin
 
284
  container := nil;
 
285
  Result := E_NOINTERFACE;
 
286
end;
 
287
 
 
288
procedure TActiveXContainer.SetActive(AValue: boolean);
 
289
begin
 
290
  if FActive=AValue then Exit;
 
291
  if AValue then
 
292
    begin
 
293
      if (FClassName='') and not assigned(ComServer) then
 
294
        raise exception.Create('OleClassName and ComServer not assigned.');
 
295
      if not assigned(FOleObject) then
 
296
        FOleObject:=CreateOleObject(FClassName);
 
297
      Attach;
 
298
    end
 
299
  else
 
300
    begin
 
301
    Detach;
 
302
    if FClassName<>'' then //destroy com object
 
303
      FOleObject:=nil;
 
304
    end;
 
305
  FActive:=AValue;
 
306
end;
 
307
 
 
308
procedure TActiveXContainer.SetClassName(AValue: string);
 
309
begin
 
310
  if (FClassName=AValue) or FActive then Exit;
 
311
  FClassName:=AValue;
 
312
end;
 
313
 
 
314
procedure TActiveXContainer.SetOleObject(AValue: IDispatch);
 
315
begin
 
316
  if (FOleObject=AValue) or FActive then Exit;
 
317
  FOleObject:=AValue;
 
318
end;
 
319
 
 
320
function TActiveXContainer.ShowObject: HResult; StdCall;
 
321
begin
 
322
  Result := S_OK;
 
323
end;
 
324
 
 
325
function TActiveXContainer.OnShowWindow(fShow: BOOL): HResult; StdCall;
 
326
begin
 
327
  Result := S_OK;
 
328
end;
 
329
 
 
330
function TActiveXContainer.RequestNewObjectLayout: HResult; StdCall;
 
331
begin
 
332
  Result := S_OK;
 
333
end;
 
334
 
 
335
function TActiveXContainer.OnControlInfoChanged: HResult; stdcall;
 
336
begin
 
337
  Result := E_NOTIMPL;
 
338
end;
 
339
 
 
340
function TActiveXContainer.LockInPlaceActive(fLock: BOOL): HResult; stdcall;
 
341
begin
 
342
  Result := E_NOTIMPL;
 
343
end;
 
344
 
 
345
function TActiveXContainer.GetExtendedControl(out disp: IDispatch): HResult; stdcall;
 
346
begin
 
347
  Result := E_NOTIMPL;
 
348
end;
 
349
 
 
350
function TActiveXContainer.TransformCoords(var ptlHimetric: TPoint;
 
351
  var ptfContainer: TPointF; flags: Longint): HResult; stdcall;
 
352
begin
 
353
  if flags and 4 <> 0 then  //XFORMCOORDS_HIMETRICTOCONTAINER=4
 
354
    begin
 
355
    ptfContainer.X := (ptlHimetric.X * Screen.PixelsPerInch) div 2540;
 
356
    ptfContainer.Y := (ptlHimetric.Y * Screen.PixelsPerInch) div 2540;
 
357
    end
 
358
  else if assigned(@ptlHimetric) and (flags and 8 <> 0) then  //XFORMCOORDS_CONTAINERTOHIMETRIC = 8
 
359
    begin
 
360
    ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / Screen.PixelsPerInch));
 
361
    ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / Screen.PixelsPerInch));
 
362
    end;
 
363
  Result := S_OK;
 
364
end;
 
365
 
 
366
function TActiveXContainer.TranslateAccelerator(msg: PMsg; grfModifiers: Longint
 
367
  ): HResult; stdcall;
 
368
begin
 
369
  Result := E_NOTIMPL;
 
370
end;
 
371
 
 
372
function TActiveXContainer.OnFocus(fGotFocus: BOOL): HResult; stdcall;
 
373
begin
 
374
  Result := S_OK;
 
375
end;
 
376
 
 
377
function TActiveXContainer.ShowPropertyFrame: HResult; stdcall;
 
378
begin
 
379
  Result := E_NOTIMPL;
 
380
end;
 
381
 
 
382
function TActiveXContainer.CanInPlaceActivate: HResult;stdcall;
 
383
begin
 
384
  Result := S_OK;
 
385
end;
 
386
 
 
387
function TActiveXContainer.OnInPlaceActivate: HResult;stdcall;
 
388
begin
 
389
  Result := S_OK;
 
390
end;
 
391
 
 
392
function TActiveXContainer.OnUIActivate: HResult; stdcall;
 
393
begin
 
394
  Result := S_OK;
 
395
end;
 
396
 
 
397
function TActiveXContainer.GetWindowContext(out ppframe: IOleInPlaceFrame; out
 
398
  ppdoc: IOleInPlaceUIWindow; lprcposrect: LPRECT; lprccliprect: LPRECT;
 
399
  lpframeinfo: LPOLEINPLACEFRAMEINFO): hresult; stdcall;
 
400
begin
 
401
    if assigned (ppframe) then
 
402
      ppframe := Self as IOleInPlaceFrame;
 
403
    if assigned(ppdoc) then
 
404
      ppdoc:= nil;
 
405
    if assigned(lpframeinfo) then
 
406
      begin
 
407
      lpframeinfo.fMDIApp := False;
 
408
      lpframeinfo.cAccelEntries := 0;
 
409
      lpframeinfo.haccel := 0;
 
410
      lpframeinfo.hwndFrame := Handle;
 
411
      end;
 
412
 
 
413
    if assigned (lprcPosRect) then
 
414
      lprcPosRect^:=GetClientRect;
 
415
    if assigned (lprcClipRect) then
 
416
      lprcClipRect^:=GetClientRect;
 
417
 
 
418
    Result := S_OK;
 
419
end;
 
420
 
 
421
function TActiveXContainer.Scroll(scrollExtant: TSIZE): hresult; stdcall;
 
422
begin
 
423
  Result := E_NOTIMPL;
 
424
end;
 
425
 
 
426
function TActiveXContainer.OnUIDeactivate(fUndoable: BOOL): hresult; stdcall;
 
427
begin
 
428
  Result := S_OK;
 
429
end;
 
430
 
 
431
function TActiveXContainer.OnInPlaceDeactivate: hresult; stdcall;
 
432
begin
 
433
  Result := S_OK;
 
434
end;
 
435
 
 
436
function TActiveXContainer.DiscardUndoState: hresult; stdcall;
 
437
begin
 
438
  Result := E_NOTIMPL;
 
439
end;
 
440
 
 
441
function TActiveXContainer.DeactivateAndUndo: hresult; stdcall;
 
442
begin
 
443
  Result := E_NOTIMPL;
 
444
end;
 
445
 
 
446
function TActiveXContainer.OnPosRectChange(lprcPosRect: LPRect): hresult; stdcall;
 
447
begin
 
448
  Result := S_OK;
 
449
end;
 
450
 
 
451
function TActiveXContainer.GetWindow(out wnd: HWnd): HResult; stdcall;
 
452
begin
 
453
  wnd:=Handle;
 
454
  Result := S_OK;
 
455
end;
 
456
 
 
457
function TActiveXContainer.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
 
458
begin
 
459
  Result := E_NOTIMPL;
 
460
end;
 
461
 
 
462
function TActiveXContainer.InsertMenus(hmenuShared: HMenu;
 
463
  var menuWidths: TOleMenuGroupWidths): HResult; StdCall;
 
464
begin
 
465
  Result := E_NOTIMPL;
 
466
end;
 
467
 
 
468
function TActiveXContainer.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
 
469
  hwndActiveObject: HWnd): HResult; StdCall;
 
470
begin
 
471
  Result := E_NOTIMPL;
 
472
end;
 
473
 
 
474
function TActiveXContainer.RemoveMenus(hmenuShared: HMenu): HResult; StdCall;
 
475
begin
 
476
  Result := S_OK;
 
477
end;
 
478
 
 
479
function TActiveXContainer.SetStatusText(pszStatusText: POleStr): HResult; StdCall;
 
480
begin
 
481
  if assigned(FOnStatusText) then
 
482
    FOnStatusText(Self,utf8encode(WideString(pszStatusText)));
 
483
  Result := S_OK;
 
484
end;
 
485
 
 
486
function TActiveXContainer.EnableModeless(fEnable: BOOL): HResult; StdCall;
 
487
begin
 
488
  Result := S_OK;
 
489
end;
 
490
 
 
491
function TActiveXContainer.TranslateAccelerator(var msg: TMsg; wID: Word): HResult;
 
492
  StdCall;
 
493
begin
 
494
  Result := E_NOTIMPL;
 
495
end;
 
496
 
 
497
function TActiveXContainer.GetBorder(out rectBorder: TRect): HResult; StdCall;
 
498
begin
 
499
  Result := INPLACE_E_NOTOOLSPACE;
 
500
end;
 
501
 
 
502
function TActiveXContainer.RequestBorderSpace(const borderwidths: TRect): HResult;
 
503
  StdCall;
 
504
begin
 
505
  Result := INPLACE_E_NOTOOLSPACE;
 
506
end;
 
507
 
 
508
function TActiveXContainer.SetBorderSpace(const borderwidths: TRect): HResult;
 
509
  StdCall;
 
510
begin
 
511
  Result := E_NOTIMPL;
 
512
end;
 
513
 
 
514
function TActiveXContainer.SetActiveObject(
 
515
  const activeObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult;
 
516
  StdCall;
 
517
begin
 
518
  Result := S_OK;
 
519
end;
 
520
 
 
521
function TActiveXContainer.GetTypeInfoCount(out count: longint): HResult;
 
522
  stdcall;
 
523
begin
 
524
  Count := 0;
 
525
  Result := S_OK;
 
526
end;
 
527
 
 
528
function TActiveXContainer.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
 
529
  ): HResult; stdcall;
 
530
begin
 
531
  Pointer(TypeInfo) := nil;
 
532
  Result := E_NOTIMPL;
 
533
end;
 
534
 
 
535
function TActiveXContainer.GetIDsOfNames(const iid: TGUID; names: Pointer;
 
536
  NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
 
537
begin
 
538
  Result := E_NOTIMPL;
 
539
end;
 
540
 
 
541
function TActiveXContainer.Invoke(DispID: LongInt; const iid: TGUID;
 
542
  LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
 
543
  ArgErr: pointer): HResult; stdcall;
 
544
const
 
545
  DISPID_AMBIENT_BACKCOLOR         = -701;
 
546
  DISPID_AMBIENT_DISPLAYNAME       = -702;
 
547
  DISPID_AMBIENT_FONT              = -703;
 
548
  DISPID_AMBIENT_FORECOLOR         = -704;
 
549
  DISPID_AMBIENT_LOCALEID          = -705;
 
550
  DISPID_AMBIENT_MESSAGEREFLECT    = -706;
 
551
  DISPID_AMBIENT_USERMODE          = -709;
 
552
  DISPID_AMBIENT_UIDEAD            = -710;
 
553
  DISPID_AMBIENT_SHOWGRABHANDLES   = -711;
 
554
  DISPID_AMBIENT_SHOWHATCHING      = -712;
 
555
  DISPID_AMBIENT_SUPPORTSMNEMONICS = -714;
 
556
  DISPID_AMBIENT_AUTOCLIP          = -715;
 
557
begin
 
558
  if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
 
559
  begin
 
560
    Result := S_OK;
 
561
    case DispID of
 
562
      DISPID_AMBIENT_BACKCOLOR:
 
563
        PVariant(VarResult)^ := Color;
 
564
      DISPID_AMBIENT_DISPLAYNAME:
 
565
        PVariant(VarResult)^ := OleVariant(Name);
 
566
      DISPID_AMBIENT_FONT:
 
567
        PVariant(VarResult)^ :=nil;
 
568
      DISPID_AMBIENT_FORECOLOR:
 
569
        PVariant(VarResult)^ := Font.Color;
 
570
      DISPID_AMBIENT_LOCALEID:
 
571
        PVariant(VarResult)^ := Integer(GetUserDefaultLCID);
 
572
      DISPID_AMBIENT_MESSAGEREFLECT:
 
573
        PVariant(VarResult)^ := False;
 
574
      DISPID_AMBIENT_USERMODE:
 
575
        PVariant(VarResult)^ := not (csDesigning in ComponentState);
 
576
      DISPID_AMBIENT_UIDEAD:
 
577
        PVariant(VarResult)^ := csDesigning in ComponentState;
 
578
      DISPID_AMBIENT_SHOWGRABHANDLES:
 
579
        PVariant(VarResult)^ := False;
 
580
      DISPID_AMBIENT_SHOWHATCHING:
 
581
        PVariant(VarResult)^ := False;
 
582
      DISPID_AMBIENT_SUPPORTSMNEMONICS:
 
583
        PVariant(VarResult)^ := True;
 
584
      DISPID_AMBIENT_AUTOCLIP:
 
585
        PVariant(VarResult)^ := True;
 
586
    else
 
587
      Result := DISP_E_MEMBERNOTFOUND;
 
588
    end;
 
589
  end else
 
590
    Result := DISP_E_MEMBERNOTFOUND;
 
591
end;
 
592
 
 
593
procedure TActiveXContainer.Attach;
 
594
var
 
595
  size:TPOINT;
 
596
begin
 
597
  SetWindowLongPtr(Handle,GWLP_USERDATA, PtrInt(Self));
 
598
  FPrevWndProc:=Windows.WNDPROC(SetWindowLongPtr(Handle,GWL_WNDPROC,PtrInt(@WndCallback)));
 
599
  FAttached:=true;
 
600
  olecheck((FOleObject as IOleObject).SetClientSite(Self as IOleClientSite));
 
601
  olecheck((FOleObject as IOleObject).SetHostNames(PWideChar(name),PWideChar(name)));
 
602
  size.x:=(Width*2540) div Screen.PixelsPerInch;
 
603
  size.y:=(Height*2540) div Screen.PixelsPerInch;
 
604
  olecheck((FOleObject as IOleObject).SetExtent(DVASPECT_CONTENT,size));
 
605
  olecheck((FOleObject as IOleObject).DoVerb(OLEIVERB_INPLACEACTIVATE,nil,Self as IOleClientSite,0,Handle,ClientRect));
 
606
end;
 
607
 
 
608
procedure TActiveXContainer.Detach;
 
609
const
 
610
  OLECLOSE_NOSAVE = 1;
 
611
begin
 
612
  if FAttached then
 
613
    begin
 
614
    SetWindowLongPtr(Handle,GWL_WNDPROC,PtrInt(@FPrevWndProc));
 
615
    SetWindowLongPtr(Handle,GWLP_USERDATA, 0);
 
616
    end;
 
617
  if assigned(FOleObject) then
 
618
    begin
 
619
    olecheck((FOleObject as IOleObject).SetClientSite(nil));
 
620
    olecheck((FOleObject as IOleObject).Close(OLECLOSE_NOSAVE));
 
621
    end;
 
622
end;
 
623
 
 
624
constructor TActiveXContainer.Create(TheOwner: TComponent);
 
625
begin
 
626
  inherited Create(TheOwner);
 
627
  parent:=TWinControl(TheOwner);
 
628
  Width:=24;
 
629
  Height:=24;
 
630
end;
 
631
 
 
632
destructor TActiveXContainer.Destroy;
 
633
begin
 
634
  Active:=false; //destroys com object if created by Self
 
635
  inherited Destroy;
 
636
end;
 
637
 
 
638
end.
 
639