source: cprs/branches/HealthSevak-CPRS/CPRS-Lib/sqasrvr.pas@ 1715

Last change on this file since 1715 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27
File size: 67.5 KB
Line 
1 {*************************************************************************
2 *
3 * Copyright 2000 - 2004 Rational Software Corporation. All Rights Reserved.
4 * This software contains proprietary and confidential information of Rational
5 * and its suppliers. Use, disclosure or reproduction is prohibited
6 * without the prior express written consent of Rational.
7 *
8 * Name: sqasrvr.pas
9 * Description:
10 *
11 * Revision History:
12 * Programmer Date Description
13 * sraj 05/18/2004 Fixed Delphi 5 compilation issues.
14 * sraj 07/25/2003 Supported TTreeView items collection in properties.
15 * sraj 07/25/2003 Supported TStringGrid object data.
16 * sraj 24/04/2003 RATLC00447073: Included FindControl1() to lookup delphi object
17 * given a window handle effectively.
18 * sraj 10/03/2002 RATLC00436896, RATLC00052492 : Included BeautifyApplicationWindow
19 * sraj 06/23/2003 RATLC00449186 : Exception trace enabled using a Registry key.
20 * sraj 10/03/2002 RATLC00436896, RATLC00052492 : Included BeautifyApplicationWindow
21 * to make application object available as a window property.
22 * Removed the call RegisterAutomationServer() from unit Initialization.
23 * PBeaulieu 01/08/2002 Changed TPublishedAutoDispatch.NewDispatch to set the found
24 * flag if found in first case to bypass the second search method.
25 * PBeaulieu 08/20/2001 Changed TIObjectDispatch.GetProperty inorder to make
26 * sure that Unassigned Variant or incorrect Variant type
27 * would not be used in retrieving a property. Changed
28 * TPublishedAutoDispatch.NewDispatch to search manually the
29 * inheritance hierarchy if InheritsFrom fails. This allows
30 * for objects that the InheritsFrom function fails on
31 * seemingly because it cannot access the information with
32 * the functions it is using. This seemed to happen with
33 * MDI app where the MDI children were created from another
34 * dll that encapsulated the form in another object.
35 * PBeaulieu 06/26/01 Merged in Pete Ness's changes to fix some warnings and
36 * to add some logging for exceptions. Also, added the function
37 * TIObjectDispatch.ParentClassName.
38 * PMNess 05/16/01 Changed the "Classname" calls in TPublishedAutoDispatch
39 * to FObject.Classname - as Classname was always
40 * returning TPublishedAutoDispatch instead of
41 * the actual invoked class.
42 * PMNess 05/15/01 Updated and removed hints/warnings under D5
43 * Added try/excepts around all automated calls
44 * to trap exceptions that may happen and log to
45 * file.
46 * KPATEL 05/25/00 Replaced the function 'VarAsType' with
47 * 'VarToStr' as Delphi 5 takes only string as
48 * the third parameter in SetStrProp function.
49 * SJPak 03/31/98 Modified TIObjectDispatch.GetEnumList to
50 * return empty variant when the total length of
51 * the strings for enumerated choices exceed
52 * 2047. This is to keep Robot from crashing
53 * Robot cannot handle more 2048 characters total.
54 * SJPak 04/02/97 Modified TPublishedAutoDispatch.Invoke to
55 * support TColor type properties.
56 * SJPak 08/04/96 Added additional interface TIStringGridDispatch
57 * to support Cols and Rows properties of TStringGrid.
58 * SJPak 03/06/97 Modified TICollectionDispatch.GetPropNames
59 * and TICollectionDispatch.GetProperty to support
60 * Items property.
61 * SJPak 11/21/96 Replacing calls to OLECheck which
62 * will raise an exception when return value
63 * is less than 0. Raising an exception
64 * will cause a messagebox to pop up when ran
65 * from Delphi IDE.
66 * SJPak 11/15/96 Fixed a memory leak in
67 * TIObjectDispatch.SetProperty
68 * SJPak 11/11/96 Modified TIStringsDispatch.GetProperty
69 * to check for empty "Strings" property.
70 * SJPak 11/07/96 Removed calls to OleError to prevent
71 * error messages being displayed during
72 * Rec/Plaback session through IDE.
73 * SJPak 10/07/96 Modified TIStringsDispatch to support
74 * Strings property of TStrings object.
75 * SJPak 09/19/96 Changed CLSID of the server.
76 * SJPak 08/04/96 Added additional interface TIOleControlDispatch
77 * to support OCXs.
78 * SJPak 08/01/96 Modified TPublishedAutoDispatch.Invoke
79 * to return tkSet type properties as
80 * a safe array of Variants containing
81 * names of all possible items in the set
82 * and booleans representing whether the items
83 * are in the particular set.
84 * SJPak 07/31/96 Fixed Borland's bug in
85 * TPublishedAutoDispatch.Invoke function's
86 * handling of min and max values of
87 * tkSet properties.
88 * SJPak 07/18/96 Changed Unit name to SQASrvr
89 * SJPak 07/18/96 Added addtional interface TIStringsDispatch
90 * to support TStrings class.
91 * SJPak 07/18/96 Added GetPropNames and GetProeprty to
92 * TICollectionDispatch.
93 * SJPak 07/18/96 Added GetPropNames method to TIObjectDispatch
94 * interface.
95 * SJPak 07/08/96 Added SetProperty method to TIObjectDispatch
96 * interface.
97 * SJPak 07/08/96 Additional interface define for
98 * DatSet Objects.
99 * SJPak 07/01/96 Fixed a bug in TPublishedAutoDispatch.Invoke
100 * SJPak 07/01/96 Additional interface defined for
101 * collections.
102 * SJPak 07/01/96 Original From Delphi.
103 *
104 **************************************************************************}
105 unit SQASrvr;
106
107 interface
108
109 uses
110 Windows,
111 {$IFDEF VER140}
112 Variants,
113 {$ENDIF}
114 {$IFDEF VER150}
115 Variants,
116 {$ELSE} //Added for Delphi 2006
117 Variants, //Added for Delphi 2006
118 {$ENDIF}
119 OleAuto,
120 OLE2, TypInfo, DB, DBTables, OleCtrls, Grids, Controls, Registry, ComCtrls;
121 const
122 AutoClassExistsMsg = 'Automation enabler for class %s is already registered';
123
124 { FirstComponentIndex needs to be high enough so that it doesn't conflict with
125 the DispIDs of the TAutoObject. The "automated" properties and methods have
126 DispIDs starting with 1 in the base object and incrementing by one from
127 there. }
128 FirstComponentIndex = $000000FF;
129 LastComponentIndex = $0000FFFE;
130 FirstPropIndex = $0000FFFF;
131 LastPropIndex = $7FFFFFFF; { maxint }
132
133 // Arbitrary Max for each element of TStrings.Strings property.
134 MaxStringItem = 32000;
135
136 type
137 { SJP Todo: This limits the set range from 0 - 15.
138 According to Doc. Set can have upto 256 elements }
139 TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1;
140 // TCardinalSet = set of 0..255;
141
142 { TPublishedAutoDispatch }
143
144 TPublishedAutoDispatch = class(TAutoDispatch)
145 private
146 FObject: TObject;
147 public
148 constructor Create(AutoObject: TAutoObject; BoundObj: TObject);
149 procedure NewDispatch(var V: Variant; Obj: TObject);
150 function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
151 cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override;
152 function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
153 flags: Word; var dispParams: TDispParams; varResult: PVariant;
154 excepInfo: PExcepInfo; argErr: PInteger): HResult; override;
155 end;
156
157 { TIObjectDispatch }
158
159 TIObjectDispatch = class(TAutoObject)
160 private
161 procedure GetProps(var v: Variant; TypeKinds: TTypeKinds);
162 protected
163 FObject: TObject;
164 function CreateAutoDispatch: TAutoDispatch; override;
165 // 5/16/2001 - PMNess - Added new GetExceptionInfo to log any
166 // exception on the invoke to a log file. This works generically when anything
167 // is called...
168 procedure GetExceptionInfo(ExceptObject: TObject;
169 var ExcepInfo: TExcepInfo); override;
170 public
171 constructor Connect(Obj: TObject); virtual;
172 automated
173 function ClassName: String;
174 function GetProperty(PropName: String): Variant;
175 function GetObject(ObjName: String): Variant;
176 procedure GetEnumList(PropName: String; var v: Variant);
177 procedure GetProperties(var v: Variant);
178 procedure GetObjects(var v: Variant);
179 function InheritsFrom(AClass: String): WordBool;
180 // SJP: 07/09/96 Added SetProperty.
181 function SetProperty(PropName: String; var v: Variant): WordBool;
182 // SJP: 07/18/96 Added SetProperty.
183 procedure GetPropNames(var v: Variant);
184 //PBeaulieu: 05/22/2001 Added ParentClassName
185 function ParentClassName: String;
186 end;
187
188 { TIComponentDispatch }
189
190 TIComponentDispatch = class(TIObjectDispatch)
191 private
192 function GetComponents(Index: Integer): Variant;
193 function GetComponentCount: Integer;
194 function GetComponentIndex: Integer;
195 function GetOwner: Variant;
196 protected // 5-16-2001 - Added protected to get rid of hint on GetDesignInfo
197 function GetDesignInfo: LongInt;
198 automated
199 property Components[Index: Integer]: Variant read GetComponents;
200 property ComponentCount: Integer read GetComponentCount;
201 property ComponentIndex: Integer read GetComponentIndex;
202 property Owner: Variant read GetOwner;
203 function FindComponent(AName: String): Variant;
204 end;
205
206 { TIControlDispatch }
207
208 TIControlDispatch = class(TIComponentDispatch)
209 private
210 function GetParent: Variant;
211 automated
212 property Parent: Variant read GetParent;
213 end;
214
215 { TIWinControlDispatch }
216
217 TIWinControlDispatch = class(TIControlDispatch)
218 private
219 function GetHandle: Integer;
220 function GetControls(Index: Integer): Variant;
221 function GetControlCount: Integer;
222 automated
223 property Handle: Integer read GetHandle;
224 property Controls[Index: Integer]: Variant read GetControls;
225 property ControlCount: Integer read GetControlCount;
226 function ControlAtPos(X, Y: Integer): Variant;
227 end;
228
229 { TIApplicationDispatch }
230
231 TIApplicationDispatch = class(TIComponentDispatch)
232 private
233 function GetHandle: Integer;
234 function GetMainForm: Variant;
235 function GetExeName: String;
236 function FindControl1(hWndToFind: HWnd): TWinControl;
237 public
238 constructor Create; override;
239 automated
240 property Handle: Integer read GetHandle;
241 property MainForm: Variant read GetMainForm;
242 property ExeName: String read GetExeName;
243 function GetDispFromHandle(Handle: Integer): Variant;
244 end;
245
246 // SJP 07/01/96 Additional interface defined for collections
247 { TICollectionDispatch }
248
249 TICollectionDispatch = class(TIObjectDispatch)
250 private
251 function GetItemCount: Integer;
252 automated
253 property ItemCount: Integer read GetItemCount;
254 procedure GetPropNames(var v: Variant);
255 function GetProperty(PropName: String): Variant;
256 end;
257
258 // SJP 07/08/96 Additional interface defined for 'dataset' objects.
259 { TIDataSetDispatch }
260
261 TIDataSetDispatch = class(TIObjectDispatch)
262 private
263 function GetFieldCount: Integer;
264 automated
265 property FieldCount: Integer read GetFieldCount;
266 function GetData: String;
267 end;
268
269 // SJP 07/18/96 Additional interface defined for TStrings Objects
270 { TIStringsDispatch }
271
272 TIStringsDispatch = class(TIObjectDispatch)
273 automated
274 function GetProperty(PropName: String): Variant;
275 procedure GetPropNames(var v: Variant);
276 end;
277
278 // SJP 08/03/96 Addition interface defined for TOleControl(OCX) Component
279 TIOleControlDispatch = class(TIWinControlDispatch)
280 private
281 function GetOleObject: Variant;
282 automated
283 property OleObject: Variant read GetOleObject;
284 end;
285
286 // SJP 03/10/97 Addition interface defined for TStringGrid Component
287 TIStringGridDispatch = class(TIWinControlDispatch)
288 automated
289 function GetProperty(PropName: String): Variant;
290 procedure GetPropNames(var v: Variant);
291 function GetData: String;
292 end;
293
294 // Addition interface defined for TTreeView Component
295 TITreeViewDispatch = class(TIWinControlDispatch)
296 automated
297 function GetProperty(PropName: String): Variant;
298 procedure GetPropNames(var v: Variant);
299 end;
300
301 { Support functions}
302
303 TIObjectDispatchRef = class of TIObjectDispatch;
304
305 PClassMapRecord = ^TClassMapRecord;
306 TClassMapRecord = record
307 ObjectClass: TClass;
308 DispClass: TIObjectDispatchRef;
309 end;
310
311 procedure FreeClassLists;
312
313 procedure RegisterAutomationEnabler( ObjectClass: TClass;
314 DispClass: TIObjectDispatchRef);
315
316 implementation
317
318 uses Forms, Classes, SysUtils;
319
320 var
321 ClassMap: TList = nil;
322
323 // Called when any exception is raised from this COM object. Logs the
324 // error to a log file.
325 procedure WriteToLog(ErrorMsg: String);
326 var
327 LogFile: TextFile;
328 LogFileName: String;
329 begin // AddToErrorLog
330 try
331 LogFileName := ExtractFilePath(ParamStr(0))+'\Robot Errors for '+ExtractFileName(ParamStr(0))+'.log';
332 AssignFile(LogFile, LogFileName);
333 if (FileExists(LogFileName))
334 then Append(LogFile)
335 else Rewrite(LogFile);
336 try
337 Writeln(LogFile, DateTimeToStr(Now)+' '+ErrorMsg);
338 finally
339 CloseFile(LogFile);
340 end;
341 except
342 // Supress this - as we're likely in some kind of error log already!
343 end;
344 end;
345
346 function IsExceptionTraceEnabled( ) : Boolean;
347 var
348 Reg: TRegistry;
349 deTrace: string;
350 begin
351 Result := False;
352 Reg := TRegistry.Create;
353 try
354 Reg.RootKey := HKEY_CURRENT_USER;
355 if Reg.OpenKey('Software\Rational Software\Rational Test\8\Robot', False) then
356 begin
357 deTrace := Reg.ReadString( 'DelphiExceptionTrace' );
358 if ( (deTrace = '1') or ( LowerCase(deTrace) = 'true' ) ) then
359 begin
360 Result := True;
361 end;
362
363 Reg.CloseKey;
364 end;
365 finally
366 Reg.Free;
367 end;
368 end;
369
370 { Exit procedure used to free memory used by the ClassList }
371 procedure FreeClassLists;
372 var
373 I: Integer;
374 begin
375 for I := 0 to ClassMap.Count-1 do
376 Dispose(PClassMapRecord(ClassMap[I]));
377 ClassMap.Free;
378 end;
379
380 { This is called in the initialization section of a unit for all new
381 automation objects. It associates an AutoObject with a VCL class. }
382 procedure RegisterAutomationEnabler(ObjectClass: TClass;
383 DispClass: TIObjectDispatchRef);
384 var
385 P: PClassMapRecord;
386 X: Integer;
387 Found: Boolean;
388 begin
389 if not Assigned(ClassMap) then
390 begin
391 AddExitProc(FreeClassLists);
392 ClassMap := TList.Create;
393 end;
394 Found := False;
395 for X := 0 to ClassMap.Count-1 do
396 begin
397 P := PClassMapRecord(ClassMap[x]);
398 if ObjectClass.InheritsFrom(P^.ObjectClass) then
399 if ObjectClass = P^.ObjectClass then
400 raise Exception.CreateFmt(AutoClassExistsMsg,[ObjectClass.ClassName])
401 else
402 begin
403 Found := True;
404 break;
405 end;
406 end;
407 New(P);
408 P^.ObjectClass := ObjectClass;
409 P^.DispClass := DispClass;
410 if Found then
411 { ObjectClass is a descendent of P^.ObjectClass, so insert the descendent
412 into the class list in front of the ancestor. }
413 ClassMap.Insert(X,P)
414 else
415 { ObjectClass is not related to any classes already in the list, so just add
416 it to the end of the list. }
417 ClassMap.Add(P);
418 end;
419
420 { TPublishedAutoDispatch }
421
422 constructor TPublishedAutoDispatch.Create(AutoObject: TAutoObject; BoundObj: TObject);
423 begin
424 inherited Create(AutoObject);
425 FObject := BoundObj;
426 end;
427
428 { NewDispatch is called to create an AutoObject bound to a VCL object.
429 Example: when the controller calls Application.MainForm.Button1.Caption,
430 NewDispatch would be called to return the dispatches for MainForm and
431 Button1. Not called directly by the controller. }
432 procedure TPublishedAutoDispatch.NewDispatch(var V: Variant; Obj: TObject);
433 var
434 i: Integer;
435 P: PClassMapRecord;
436 Found: Boolean;
437 Cls: TClass;
438 begin
439 VarClear(V);
440 Found := FALSE;
441 if not (Assigned(Obj) and Assigned(ClassMap)) then Exit;
442 for i := 0 to ClassMap.Count - 1 do
443 begin
444 P := PClassMapRecord(ClassMap[i]);
445 if Obj.InheritsFrom(P^.ObjectClass) then
446 begin
447 V := P^.DispClass.Connect(Obj).OleObject;
448 { Do a release here because the Connect does an AddRef and the
449 OleObject does an AddRef, we only want 1. }
450 VarToInterface(V).Release;
451 Found := TRUE;
452 break;
453 end;
454 end;
455
456 if Found = FALSE then
457 begin
458 for i := 0 to ClassMap.Count - 1 do
459 begin
460 P := PClassMapRecord(ClassMap[i]);
461
462 if Obj.ClassName = P^.ObjectClass.ClassName then
463 begin
464 V := P^.DispClass.Connect(Obj).OleObject;
465 { Do a release here because the Connect does an AddRef and the
466 OleObject does an AddRef, we only want 1. }
467 VarToInterface(V).Release;
468 break;
469 end;
470
471 Cls := Obj.ClassParent;
472
473 while( Cls <> nil ) do
474 begin
475 if Cls.ClassName = P^.ObjectClass.ClassName then
476 begin
477 V := P^.DispClass.Connect(Obj).OleObject;
478 { Do a release here because the Connect does an AddRef and the
479 OleObject does an AddRef, we only want 1. }
480 VarToInterface(V).Release;
481 Found := TRUE;
482 break;
483 end;
484 Cls := Cls.ClassParent;
485 end;
486
487 if Found = TRUE then
488 begin
489 break;
490 end;
491 end;
492 end;
493 end;
494
495 { Searches through the published properties of the associated object for the
496 requested name (property). If it is not found it calls the inherited
497 GetIDsOfNames which will then search through the TAutoObject's "automated"
498 section for the name. }
499 function TPublishedAutoDispatch.GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
500 cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult;
501 var
502 PropName: string;
503 SubComponent: TComponent;
504 begin
505 if cNames <> 1 then
506 begin
507 Result := inherited GetIDsOfNames(iid, rgszNames, cNames, lcid, rgdispid);
508 Exit;
509 end;
510 Result := DISP_E_UNKNOWNNAME;
511 PropName := WideCharToString(rgszNames^[0]);
512 rgdispid^[0] := TDISPID(GetPropInfo(FObject.ClassInfo, PropName));
513 if rgdispid^[0] <> 0 then
514 begin
515 if PPropInfo(rgdispid^[0])^.PropType^.Kind in [tkInteger, tkEnumeration,
516 tkString, tkFloat, tkClass, tkSet, tkMethod, tkLString{, tkLWString}] then
517 Result := S_OK;
518 end
519 else if FObject is TComponent then
520 begin
521 SubComponent := TComponent(FObject).FindComponent(PropName);
522 if SubComponent <> nil then
523 begin
524 rgdispid^[0] := FirstComponentIndex + TDispID(SubComponent.ComponentIndex);
525 Result := S_OK;
526 end;
527 end;
528 { Pass to inherited if nothing resolves the call. }
529 if Result <> S_OK then
530 Result := inherited GetIDsOfNames(iid, rgszNames, cNames, lcid, rgdispid);
531 end;
532
533 { Gets a property or calls a method of the associated object. If the
534 dispIDMember is less than FirstComponentIndex it should be in the AutoObject,
535 otherwise it attempts to find the request in the published section of the
536 associated object. }
537 function TPublishedAutoDispatch.Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
538 flags: Word; var dispParams: TDispParams; varResult: PVariant;
539 excepInfo: PExcepInfo; argErr: PInteger): HResult;
540 var
541 PropInfo: PPropInfo;
542 W: Cardinal;
543 TypeInfo: PTypeInfo;
544 TypeData: PTypeData;
545 ErrorMessage: String;
546 I: Integer;
547 J: Integer;
548 // SetItemString: String;
549 begin
550 Result := DISP_E_MEMBERNOTFOUND;
551 PropInfo := NIL;
552 try
553 { If it is a component then call NewDispatch to return the IDispatch to
554 the controller }
555 if (dispIDMember >= FirstComponentIndex) and
556 (dispIDMember <= LastComponentIndex) then
557 begin
558 NewDispatch(VarResult^,TComponent(FObject).Components[dispIDMember - FirstComponentIndex]);
559 Result := S_OK;
560 end
561 { Check to see if it is a property }
562 else if (dispIDMember >= FirstPropIndex) then
563 // and (dispIDMember <= LastPropIndex) 5-16-2001 Removed - as this is always true
564 begin
565 PropInfo := PPropInfo(dispIDMember);
566 if Flags and DISPATCH_PROPERTYGET <> 0 then //Only Get Property
567 begin
568 VarClear(VarResult^);
569 Result := S_OK;
570 case PropInfo^.PropType^.Kind of
571 tkInteger:
572 begin
573 VarResult^ := GetOrdProp(FObject, PropInfo);
574 // SJP: 04/02/97 Modifying original.
575 // Set a flag to indicate Color property.
576 if PropInfo^.PropType^.Name = 'TColor' then
577 begin
578 TVariantArg(VarResult^).wReserved1 := 8;
579 end;
580 end;
581 tkEnumeration:
582 // SJP: 07/10/96 Modifying original.
583 // Now tkEnumeration properties will
584 // be returned as VT_I2;
585 begin
586 //TVariantArg(VarResult^).vt := VT_BSTR;
587 //TVariantArg(VarResult^).bstrVal := StringToOleStr(
588 //GetEnumName(PropInfo^.PropType, GetOrdProp(FObject, PropInfo)));
589 TVariantArg(VarResult^).vt := VT_I2;
590 TVariantArg(VarResult^).iVal := GetOrdProp(FObject, PropInfo);
591 end;
592 tkFloat:
593 VarResult^ := GetFloatProp(FObject, PropInfo);
594 tkString:
595 VarResult^ := GetStrProp(FObject, PropInfo);
596 tkSet:
597 begin
598 // SJP: 07/31/96 Modifying the original.
599 // Changing to return a safe array of Variants containing
600 // Names of all possible items in the set
601 // and booleans representing whether the items are
602 // in this particular set.
603 // SetItemString := '[';
604 W := GetOrdProp(FObject, PropInfo);
605 {$IFDEF VER90}
606 TypeData := GetTypeData(PropInfo^.PropType);
607 TypeInfo := TypeData^.CompType;
608 {$ELSE}
609 TypeData := GetTypeData(PropInfo^.PropType^);
610 TypeInfo := TypeData^.CompType^;
611 {$ENDIF}
612 // SJP: 07/31/96 Modifying the original Borland code.
613 // Get the TypeData again from the TypeInfo
614 // TypeInfo represents the OrdType of the set.
615 // the new TypeData will have correct MinValue and MaxValue.
616 TypeData := GetTypeData(TypeInfo);
617 VarResult^ := VarArrayCreate([0, TypeData^.MaxValue - TypeData^.MinValue, 0, 1], varVariant);
618 J := 0;
619 for I := TypeData^.MinValue to TypeData^.MaxValue do
620 begin
621 VarResult^[J, 0] := GetEnumName(TypeInfo, I);
622 if I in TCardinalSet(W) then
623 VarResult^[J, 1] := True
624 else
625 VarResult^[J, 1] := False;
626 J := J + 1;
627 end;
628 // begin
629 // if Length(SetItemString) <> 1 then
630 // SetItemString := SetItemString + ',';
631 // SetItemString := SetItemString + GetEnumName(TypeInfo, I);
632 // end;
633 // SetItemString := SetItemString + ']';
634 // TVariantArg(VarResult^).vt := VT_BSTR;
635 // TVariantArg(VarResult^).bstrVal := StringToOleStr(SetItemString);
636 end;
637 tkClass:
638 NewDispatch(VarResult^, TObject(GetOrdProp(FObject, PropInfo)));
639 tkLString:
640 begin
641 TVariantArg(VarResult^).vt := VT_BSTR;
642 TVariantArg(VarResult^).bstrVal := StringToOleStr(GetStrProp(FObject, PropInfo));
643 end;
644 else
645 Result := E_NOTIMPL;
646 end;
647 end
648 else if Flags and DISPATCH_PROPERTYPUT <> 0 then
649 begin
650 Result := S_OK;
651 case PropInfo^.PropType^.Kind of
652 tkInteger:
653 SetOrdProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varInteger));
654 tkString:
655 // KPATEL: Replaced the function 'VarAsType' with 'VarToStr' as Delphi 5
656 // takes only string as the third parameter in SetStrProp function.
657 // SetStrProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varString));
658 SetStrProp(FObject, PropInfo, VarToStr(Variant(dispParams.rgvarg[0])));
659 tkLString:
660 // KPATEL: Replaced the function 'VarAsType' with 'VarToStr' as Delphi 5
661 // takes only string as the third parameter in SetStrProp function.
662 // SetStrProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varString));
663 SetStrProp(FObject, PropInfo, VarToStr(Variant(dispParams.rgvarg[0])));
664 tkEnumeration:
665 SetOrdProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varSmallInt));
666 tkFloat:
667 SetFloatProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varSingle));
668 { tkSet:
669 begin
670 SetItemString := '[';
671 W := GetOrdProp(FObject, PropInfo);
672 TypeData := GetTypeData(PropInfo^.PropType);
673 TypeInfo := TypeData^.CompType;
674 // SJP: Commented out because TypeData^.MinValue/MaxValue is
675 // bogus.
676 // ShowMessage(IntToStr(TypeData^.MinValue));
677 // ShowMessage(IntToStr(TypeData^.MaxValue));
678 // for I := TypeData^.MinValue to TypeData^.MaxValue do
679 for I := 0 to 255 do
680 if I in TCardinalSet(W) then
681 begin
682 if Length(SetItemString) <> 1 then
683 SetItemString := SetItemString + ',';
684 SetItemString := SetItemString + GetEnumName(TypeInfo, I);
685 end;
686 SetItemString := SetItemString + ']';
687 TVariantArg(VarResult^).vt := VT_BSTR;
688 TVariantArg(VarResult^).bstrVal := StringToOleStr(SetItemString);
689 end;}
690 else
691 Result := E_NOTIMPL;
692 end;
693 end;
694 end;
695 { If not found then pass it to the TAutoDispatch.Invoke method. }
696 if Result <> S_OK then
697 begin
698 Result := inherited Invoke(dispIDMember, iid, lcid, flags, dispParams,
699 varResult, excepInfo, argErr);
700 end
701 except
702 on E:Exception
703 do begin
704 ErrorMessage := FObject.ClassName;
705 if (Assigned(PropInfo)) then ErrorMessage := ErrorMessage + '.' + PropInfo.Name;
706
707 if ExcepInfo <> nil then
708 begin
709 FillChar(ExcepInfo^, 0, SizeOf(TExcepInfo));
710 //Copied this from TAutoObject.GetExceptionInfo
711 with ExcepInfo^ do
712 begin
713 bstrSource := StringToOleStr(FObject.ClassName);
714 if ExceptObject is Exception then
715 begin
716 bstrDescription := StringToOleStr(Exception(ExceptObject).Message);
717 ErrorMessage := ErrorMessage + ': ' + Exception(ExceptObject).Message;
718 end
719 else ErrorMessage := ErrorMessage + ': ' + E.Message;
720 scode := E_FAIL;
721 end;
722 end
723 else ErrorMessage := ErrorMessage + ': ' + E.Message;
724
725 WriteToLog(ErrorMessage);
726 Result := DISP_E_EXCEPTION;
727 end;
728 end;
729 end;
730
731 { TIObjectDispatch }
732
733 { Obj is the Object that is being "Bound" to here. This AutoObject will then
734 surface properties for Obj. }
735 constructor TIObjectDispatch.Connect(Obj: TObject);
736 begin
737 FObject := Obj;
738 inherited Create;
739 end;
740
741 function TIObjectDispatch.CreateAutoDispatch: TAutoDispatch;
742 begin
743 Result := TPublishedAutoDispatch.Create(Self, FObject);
744 end;
745
746 // New override to trap exceptions raised in the invoke.
747 // 5/16/2001 - PMNess
748 procedure TIObjectDispatch.GetExceptionInfo(ExceptObject: TObject;
749 var ExcepInfo: TExcepInfo);
750 begin
751 try
752 if (ExceptObject is Exception) then
753 begin
754 WriteToLog(PChar(Exception(ExceptObject).Message));
755 end;
756 except
757 // 5/16/2001 - PMNess
758 // If the exception object has a problem, we don't want to cause another
759 // exception here, so just mask it.
760 end;
761 inherited;
762 end;
763
764 function TIObjectDispatch.ClassName: String;
765 begin
766 Result := FObject.ClassName;
767 end;
768
769 function TIObjectDispatch.ParentClassName: String;
770 var
771 P: TClass;
772 ClassNames: String;
773 begin
774 P := FObject.ClassParent;
775 ClassNames := '';
776
777 while( P <> nil ) do
778 begin
779 if Length(ClassNames) > 0 then
780 begin
781 ClassNames := ClassNames + ',';
782 end;
783
784 ClassNames := ClassNames + P.ClassName;
785
786 P := P.ClassParent;
787 end;
788
789 Result := ClassNames;
790 end;
791
792 function TIObjectDispatch.InheritsFrom(AClass: String): WordBool;
793 var
794 P: TClass;
795 begin
796 P := FObject.ClassType;
797 while (P <> nil) and (CompareText(P.ClassName, AClass) <> 0) do
798 P := P.ClassParent;
799 Result := P <> nil;
800 end;
801
802 { Just a friendly wrapper around GetProperty for ease of use }
803 function TIObjectDispatch.GetObject(ObjName: String): Variant;
804 begin
805 Result := GetProperty(ObjName);
806 end;
807
808 { GetProperty can take a full path to a property or object
809 (ie Form1.Button1.Caption) and return the value of the property or object
810 as a variant. }
811 function TIObjectDispatch.GetProperty(PropName: String): Variant;
812 var
813 Params: TDispParams;
814 Index: TDISPID;
815 ExpInfo: TEXCEPINFO;
816 ArgErr: Integer;
817 PWStr: PWideChar;
818 Name: String;
819 Idx: Integer;
820 Holder: Variant;
821 guid: TGUID;
822 begin
823 FillChar(Params,SizeOf(Params),0);
824 FillChar(ExpInfo,SizeOf(ExpInfo),0);
825 ArgErr := 0;
826 Idx := Pos('.', PropName);
827 if Idx > 0 then
828 begin
829 Name := Copy(PropName,1,Idx - 1);
830 Delete(PropName,1,Idx);
831 end
832 else
833 Name := PropName;
834 PWStr := StringToOleStr(Name);
835
836 // 11/21/96 SJPak Replacing calls to OLECheck which will raise an exception
837 // when return value is less than 0. Raising an exception
838 // will cause a messagebox to pop up when ran from IDE.
839 if AutoDispatch.GetIDsOfNames(guid, @PWStr, 1, 0, @Index) >= 0 then
840 if AutoDispatch.Invoke(Index, guid, 0, Dispatch_PropertyGet or Dispatch_Method,
841 Params, @Holder, @ExpInfo, @ArgErr) >= 0 then
842 if VarType(Holder) = varDispatch then
843 VarToInterface(Holder).AddRef;
844
845 SysFreeString(PWStr);
846
847 if ( not VarIsEmpty( Holder ) ) and ( VarType( Holder ) = varDispatch ) and ( Idx > 0 ) then
848 begin
849 Result := Holder.GetProperty(PropName);
850 VarToInterface(Holder).Release;
851 VarClear(Holder);
852 end
853 else if ( VarIsEmpty( Holder ) ) then
854 begin
855 Holder := NULL;
856 // VarClear( Holder );
857 Result := Holder;
858 end
859 else
860 Result := Holder;
861 end;
862
863 procedure TIObjectDispatch.GetProps(var v: Variant; TypeKinds: TTypeKinds);
864 var
865 I, J, Count: Integer;
866 PropInfo: PPropInfo;
867 TempList: PPropList;
868 SetItemString: String;
869 W: Cardinal;
870 begin
871 Count := GetPropList(FObject.ClassInfo, TypeKinds, nil);
872 if Count > 0 then
873 begin
874 v := VarArrayCreate([0, Count - 1, 0, 2], varVariant);
875 GetMem(TempList, Count * SizeOf(Pointer));
876 try
877 GetPropList(FObject.ClassInfo, TypeKinds, TempList);
878 for I := 0 to Count - 1 do
879 begin
880 PropInfo := TempList^[I];
881 v[i,2] := PropInfo^.PropType^.Kind;
882 case PropInfo^.PropType^.Kind of
883 tkClass:
884 begin
885 v[i,0] := PropInfo^.Name;
886 v[i,1] := '(' + PropInfo^.PropType^.Name + ')';
887 end;
888 tkString,
889 tkLString:
890 begin
891 v[i,0] := PropInfo^.Name;
892 v[i,1] := GetStrProp(FObject,PropInfo);
893 end;
894 tkChar:
895 begin
896 v[i,0] := PropInfo^.Name;
897 v[i,1] := Chr(GetOrdProp(FObject,PropInfo));
898 if IsCharAlpha(Chr(GetOrdProp(FObject,PropInfo))) then
899 v[i,1] := Chr(GetOrdProp(FObject,PropInfo))
900 else
901 v[i,1] := '#' + IntToStr(GetOrdProp(FObject,PropInfo));
902 end;
903 tkInteger:
904 begin
905 v[i,0] := PropInfo^.Name;
906 v[i,1] := IntToStr(GetOrdProp(FObject,PropInfo));
907 end;
908 tkFloat:
909 begin
910 v[i,0] := PropInfo^.Name;
911 v[i,1] := FloatToStr(GetFloatProp(FObject,PropInfo));
912 end;
913 tkEnumeration:
914 begin
915 v[i,0] := PropInfo^.Name;
916 {$IFDEF VER90}
917 v[i,1] := GetEnumName(PropInfo^.PropType, GetOrdProp(FObject, PropInfo));
918 {$ELSE}
919 v[i,1] := GetEnumName(PropInfo^.PropType^, GetOrdProp(FObject, PropInfo));
920 {$ENDIF}
921 end;
922 tkSet:
923 begin
924 v[i,0] := PropInfo^.Name;
925 SetItemString := '[';
926 W := GetOrdProp(FObject, PropInfo);
927 for J := 0 to 15 do
928 if J in TCardinalSet(W) then
929 begin
930 if Length(SetItemString) <> 1 then
931 SetItemString := SetItemString + ',';
932 SetItemString := SetItemString +
933 {$IFDEF VER90}
934 GetEnumName(GetTypeData(PropInfo^.PropType)^.CompType, J);
935 {$ELSE}
936 GetEnumName(GetTypeData(PropInfo^.PropType^)^.CompType^, J);
937 {$ENDIF}
938 end;
939 SetItemString := SetItemString + ']';
940 v[i,1] := SetItemString;
941 end;
942 tkVariant:
943 try
944 v[i,0] := PropInfo^.Name;
945 v[i,1] := VarAsType(GetVariantProp(FObject,PropInfo), varString);
946 except
947 v[i,1] := '(Variant)';
948 end;
949 //None of these area implemented...
950 // tkWChar:
951 // tkLWString:
952 // tkUnknown:
953 // tkMethod:
954 end;
955 end;
956 finally
957 FreeMem(TempList, Count * SizeOf(Pointer));
958 end;
959 end;
960 end;
961
962 procedure TIObjectDispatch.GetProperties(var v: Variant);
963 const
964 TypeKinds: TTypeKinds = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat,
965 tkString, tkSet, tkClass, {tkMethod, }{tkWChar, }tkLString, {tkLWString,}
966 tkVariant];
967 begin
968 GetProps(v, TypeKinds);
969 end;
970
971 procedure TIObjectDispatch.GetObjects(var v: Variant);
972 begin
973 GetProps(v, [tkClass]);
974 end;
975
976 { Given the property name this will return an array containing the possible
977 values of an enum. }
978 procedure TIObjectDispatch.GetEnumList(PropName: String; var v: Variant);
979 var
980 Name: String;
981 Idx: Integer;
982 Obj: Variant;
983 I, J: Integer;
984 TotalLength: Integer;
985 PropInfo: PPropInfo;
986 TypeData: PTypeData;
987 begin
988 Idx := Length(PropName);
989 while (Idx > 0) and (PropName[Idx] <> '.') do
990 Dec(Idx);
991 if Idx > 0 then
992 begin
993 Name := PropName;
994 Delete(Name,1,Idx);
995 Obj := GetProperty(Copy(PropName,1,Idx - 1));
996 try
997 Obj.GetEnumList(Name,v);
998 finally
999 VarToInterface(Obj).Release;
1000 end;
1001 end
1002 else
1003 begin
1004 PropInfo := GetPropInfo(FObject.ClassInfo,PropName);
1005 if PropInfo^.PropType^.Kind <> tkEnumeration then
1006 raise EOleSysError(DISP_E_TYPEMISMATCH);
1007 {$IFDEF VER90}
1008 TypeData := GetTypeData(PropInfo^.PropType);
1009 {$ELSE}
1010 TypeData := GetTypeData(PropInfo^.PropType^);
1011 {$ENDIF}
1012 j := TypeData^.MaxValue - TypeData^.MinValue;
1013 v := VarArrayCreate([0, j], varVariant);
1014 j := 0;
1015 TotalLength := 0;
1016 for i := TypeData^.MinValue to TypeData^.MaxValue do
1017 begin
1018 {$IFDEF VER90}
1019 v[j] := GetEnumName(PropInfo^.PropType,i);
1020 {$ELSE}
1021 v[j] := GetEnumName(PropInfo^.PropType^,i);
1022 {$ENDIF}
1023 TotalLength := TotalLength + Length(v[j]) + 1;
1024 Inc(j);
1025 end;
1026
1027 // SJP 3/31/98 Temporary fix to allow buffer overwrite in 6.1 SQAXDEL.DLL
1028 if TotalLength > 2047 then
1029 begin
1030 v := UnAssigned;
1031 end;
1032
1033 end;
1034 end;
1035
1036 // SJP: 07/09/96 Added SetProperty.
1037 function TIObjectDispatch.SetProperty(PropName: String; var v: Variant): WordBool;
1038 var
1039 Params: TDispParams;
1040 Index: TDISPID;
1041 ExpInfo: TEXCEPINFO;
1042 ArgErr: Integer;
1043 PWStr: PWideChar;
1044 Name: String;
1045 Idx: Integer;
1046 Obj: Variant;
1047 guid: TGUID;
1048 bSuccess: WordBool;
1049 begin
1050 bSuccess := True;
1051 // Separate the last property from the full path name.
1052 Idx := Length(PropName);
1053 while (Idx > 0) and (PropName[Idx] <> '.') do
1054 Dec(Idx);
1055 if Idx > 0 then
1056 begin
1057 Name := PropName;
1058 Delete(Name,1,Idx);
1059 Obj := GetProperty(Copy(PropName,1,Idx - 1));
1060 try
1061 bSuccess := Obj.SetProperty(Name,v);
1062 finally
1063 VarToInterface(Obj).Release;
1064 end;
1065 end
1066 else
1067 begin
1068 FillChar(Params,SizeOf(Params),0);
1069 FillChar(ExpInfo,SizeOf(ExpInfo),0);
1070 ArgErr := 0;
1071 PWStr := StringToOleStr(PropName);
1072 New(Params.rgvarg);
1073 Params.rgvarg[0] := TVariantArg(v);
1074 params.cArgs := 1;
1075
1076 // 11/21/96 SJPak Replacing calls to OLECheck which will raise an exception
1077 // when return value is less than 0. Raising an exception
1078 // will cause a messagebox to pop up when ran from IDE.
1079 if AutoDispatch.GetIDsOfNames(guid, @PWStr, 1, 0, @Index) >= 0 then
1080 begin
1081 if AutoDispatch.Invoke(Index, guid, 0, Dispatch_PropertyPut,
1082 Params, nil, @ExpInfo, @ArgErr) < 0 then
1083 bSuccess := False;
1084 end
1085 else
1086 bSuccess := False;
1087
1088 SysFreeString(PWStr);
1089 Dispose(params.rgvarg);
1090 end;
1091 Result := bSuccess;
1092 end;
1093
1094 // SJP: 07/18/96 Added.
1095 procedure TIObjectDispatch.GetPropNames(var v: Variant);
1096 const
1097 TypeKinds: TTypeKinds = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat,
1098 tkString, tkSet, tkClass, {tkMethod, }{tkWChar, }tkLString, {tkLWString,}
1099 tkVariant];
1100 var
1101 I, Count: Integer;
1102 PropInfo: PPropInfo;
1103 TempList: PPropList;
1104 begin
1105 Count := GetPropList(FObject.ClassInfo, TypeKinds, nil);
1106 if Count > 0 then
1107 begin
1108 v := VarArrayCreate([0, Count - 1, 0, 1], varVariant);
1109 GetMem(TempList, Count * SizeOf(Pointer));
1110 try
1111 GetPropList(FObject.ClassInfo, TypeKinds, TempList);
1112 for I := 0 to Count - 1 do
1113 begin
1114 PropInfo := TempList^[I];
1115 v[i,1] := PropInfo^.PropType^.Kind;
1116 case PropInfo^.PropType^.Kind of
1117 tkClass:
1118 v[i,0] := PropInfo^.Name;
1119 tkString,
1120 tkLString:
1121 v[i,0] := PropInfo^.Name;
1122 tkChar:
1123 v[i,0] := PropInfo^.Name;
1124 tkInteger:
1125 v[i,0] := PropInfo^.Name;
1126 tkFloat:
1127 v[i,0] := PropInfo^.Name;
1128 tkEnumeration:
1129 v[i,0] := PropInfo^.Name;
1130 tkSet:
1131 v[i,0] := PropInfo^.Name;
1132 tkVariant:
1133 v[i,0] := PropInfo^.Name;
1134 //None of these area implemented...
1135 // tkWChar:
1136 // tkLWString:
1137 // tkUnknown:
1138 // tkMethod:
1139 end;
1140 end;
1141 finally
1142 FreeMem(TempList, Count * SizeOf(Pointer));
1143 end;
1144 end;
1145 end;
1146
1147
1148 { TIComponentDispatch }
1149
1150 function TIComponentDispatch.GetComponents(Index: Integer): Variant;
1151 begin
1152 if (Index >= 0) and (Index < TComponent(FObject).ComponentCount) then
1153 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TComponent(FObject).Components[Index])
1154 else
1155 ;
1156 // OleError(DISP_E_BADINDEX);
1157 end;
1158
1159 function TIComponentDispatch.GetComponentCount: Integer;
1160 begin
1161 Result := TComponent(FObject).ComponentCount;
1162 end;
1163
1164 function TIComponentDispatch.GetComponentIndex: Integer;
1165 begin
1166 Result := TComponent(FObject).ComponentIndex;
1167 end;
1168
1169 function TIComponentDispatch.GetOwner: Variant;
1170 begin
1171 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TComponent(FObject).Owner)
1172 end;
1173
1174 function TIComponentDispatch.GetDesignInfo: LongInt;
1175 begin
1176 Result := TComponent(FObject).DesignInfo;
1177 end;
1178
1179 function TIComponentDispatch.FindComponent(AName: String): Variant;
1180 var
1181 Obj: TComponent;
1182 begin
1183 Obj := TComponent(FObject).FindComponent(AName);
1184 if Obj <> nil then
1185 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Obj)
1186 else
1187 ;
1188 // OleError(DISP_E_UNKNOWNNAME);
1189 end;
1190
1191 { TICollectionDispatch }
1192
1193 function TICollectionDispatch.GetItemCount: Integer;
1194 begin
1195 Result := TCollection(FObject).Count;
1196 end;
1197
1198 procedure TICollectionDispatch.GetPropNames(var v: Variant);
1199 var
1200 Count, I : Integer;
1201 vTemp : Variant;
1202 begin
1203 inherited GetPropNames(vTemp);
1204 Count := -1;
1205 if VarIsArray(vTemp) then
1206 Count := VarArrayHighBound(vTemp, 1);
1207 v := VarArrayCreate([0, Count + 2, 0, 1], varVariant);
1208 for I := 0 to Count do
1209 begin
1210 v[I, 0] := vTemp[I, 0];
1211 v[I, 1] := vTemp[1, 1];
1212 end;
1213 v[Count + 1, 0] := 'Count';
1214 v[Count + 1, 1] := tkInteger;
1215 v[Count + 2, 0] := 'Items';
1216 v[Count + 2, 1] := tkClass;
1217 VarClear(vTemp);
1218 end;
1219
1220 function TICollectionDispatch.GetProperty(PropName: String): Variant;
1221 var
1222 Count: Integer;
1223 I: Integer;
1224 Item: Variant;
1225 Holder: Variant;
1226 begin
1227 if Propname = 'Count' then
1228 begin
1229 Holder := TCollection(FObject).Count;
1230 Result := Holder;
1231 end
1232 else if Propname = 'Items' then
1233 begin
1234 Count := TCollection(FObject).Count;
1235 Holder := VarArrayCreate([0, Count-1], varDispatch);
1236 for I := 0 to Count-1 do
1237 begin
1238 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TCollection(FObject).Items[I]);
1239 Holder[I] := Item;
1240 end;
1241 Result := Holder;
1242 end
1243 else
1244 Result := inherited GetProperty(PropName);
1245 end;
1246
1247 { TIDataSetDispatch }
1248 // SJP. 07/08/96 Returns FieldCount for TDataSet Objects.
1249 function TIDataSetDispatch.GetFieldCount: Integer;
1250 begin
1251 Result := TDataSet(FObject).FieldCount;
1252 end;
1253
1254 // SJP. 07/08/96 Returns Tab-delimited/New-line separated
1255 // 'data' for TDataSet Objects.
1256 function TIDataSetDispatch.GetData: String;
1257 var
1258 I: Integer;
1259 Data: String;
1260 InitialBookMark: TBookMark;
1261 begin
1262 InitialBookMark := TDataSet(FObject).GetBookMark;
1263 Data := '';
1264 TDataSet(FObject).First;
1265 while TDataSet(FObject).EOF = False do
1266 begin
1267 for I := 0 to TDataSet(FObject).FieldCount - 1 do
1268 begin
1269 if TDataSet(FObject).Fields[I].InheritsFrom(TMemoField) then
1270 Data := Data + '(Memo)'
1271 else if TDataSet(FObject).Fields[I].InheritsFrom(TGraphicField) then
1272 Data := Data + '(Graphic)'
1273 else if TDataSet(FObject).Fields[I].InheritsFrom(TBlobField) then
1274 Data := Data + '(Blob)'
1275 else if TDataSet(FObject).Fields[I].InheritsFrom(TBytesField) then
1276 Data := Data + '(Bytes)'
1277 else if TDataSet(FObject).Fields[I].InheritsFrom(TVarBytesField) then
1278 Data := Data + '(Var Bytes)'
1279 else
1280 Data := Data + TDataSet(FObject).Fields[I].AsString;
1281 if I < TDataSet(FObject).FieldCount - 1 then
1282 Data := Data + #9;
1283 end;
1284 TDataSet(FObject).Next;
1285 Data := Data + #13;
1286 end;
1287 TDataSet(FObject).GotoBookMark(InitialBookMark);
1288 TDataSet(FObject).FreeBookMark(InitialBookMark);
1289 Result := Data;
1290 end;
1291
1292 { TIStringDispatch }
1293
1294 procedure TIStringsDispatch.GetPropNames(var v: Variant);
1295 var
1296 Count, I : Integer;
1297 vTemp : Variant;
1298 begin
1299 inherited GetPropNames(vTemp);
1300 Count := -1;
1301 if VarIsArray(vTemp) then
1302 Count := VarArrayHighBound(vTemp, 1);
1303 v := VarArrayCreate([0, Count + 2, 0, 1], varVariant);
1304 for I := 0 to Count do
1305 begin
1306 v[I, 0] := vTemp[I, 0];
1307 v[I, 1] := vTemp[1, 1];
1308 end;
1309 v[Count + 1, 0] := 'Text';
1310 v[Count + 1, 1] := tkString;
1311 v[Count + 2, 0] := 'Strings';
1312 v[Count + 2, 1] := tkString;
1313 VarClear(vTemp);
1314 end;
1315
1316 function TIStringsDispatch.GetProperty(PropName: String): Variant;
1317 var
1318 I: Integer;
1319 Count: Integer;
1320 Holder: Variant;
1321 begin
1322 if Propname = 'Strings' then
1323 begin
1324 Count := TStrings(FObject).Count;
1325 if Count > 0 then
1326 begin
1327 Holder := VarArrayCreate([0, Count-1], varOleStr);
1328 for I := 0 to Count-1 do
1329 begin
1330 // Arbitrary Max len of 32000
1331 Holder[I] := Copy(TStrings(FObject).Strings[I], 0, MaxStringItem);
1332 end;
1333 end;
1334 Result := Holder;
1335 end
1336 else if Propname = 'Text' then
1337 begin
1338 Holder := TStrings(FObject).Text;
1339 Result := Holder;
1340 end
1341 else
1342 Result := inherited GetProperty(PropName);
1343 end;
1344
1345 { TIOleControlDispatch }
1346
1347 function TIOleControlDispatch.GetOleObject: Variant;
1348 begin
1349 Result := TOleControl(FObject).OleObject;
1350 end;
1351
1352 { TIStringGridDispatch }
1353
1354 procedure TIStringGridDispatch.GetPropNames(var v: Variant);
1355 var
1356 Count, I : Integer;
1357 vTemp : Variant;
1358 begin
1359 inherited GetPropNames(vTemp);
1360 Count := -1;
1361 if VarIsArray(vTemp) then
1362 Count := VarArrayHighBound(vTemp, 1);
1363 v := VarArrayCreate([0, Count + 2, 0, 1], varVariant);
1364 for I := 0 to Count do
1365 begin
1366 v[I, 0] := vTemp[I, 0];
1367 v[I, 1] := vTemp[1, 1];
1368 end;
1369 v[Count + 1, 0] := 'Cols';
1370 v[Count + 1, 1] := tkClass;
1371 v[Count + 2, 0] := 'Rows';
1372 v[Count + 2, 1] := tkClass;
1373 VarClear(vTemp);
1374 end;
1375
1376 function TIStringGridDispatch.GetProperty(PropName: String): Variant;
1377 var
1378 Count: Integer;
1379 I: Integer;
1380 Item: Variant;
1381 Holder: Variant;
1382 begin
1383 if Propname = 'Cols' then
1384 begin
1385 Count := TStringGrid(FObject).ColCount;
1386 Holder := VarArrayCreate([0, Count-1], varDispatch);
1387 for I := 0 to Count-1 do
1388 begin
1389 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TStringGrid(FObject).Cols[I]);
1390 Holder[I] := Item;
1391 end;
1392 Result := Holder;
1393 end
1394 else if Propname = 'Rows' then
1395 begin
1396 Count := TStringGrid(FObject).RowCount;
1397 Holder := VarArrayCreate([0, Count-1], varDispatch);
1398 for I := 0 to Count-1 do
1399 begin
1400 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TStringGrid(FObject).Rows[I]);
1401 Holder[I] := Item;
1402 end;
1403 Result := Holder;
1404 end
1405 else
1406 Result := inherited GetProperty(PropName);
1407 end;
1408
1409 function TIStringGridDispatch.GetData: String;
1410 var
1411 row, col, RowCount, ColCount: Integer;
1412 DataTemp, Data: String;
1413 begin
1414 //OutputDebugString( PChar( 'TIStringGridDispatch.GetData : ' + #13#10 ) );
1415 Data := '';
1416
1417 RowCount := TStringGrid(FObject).RowCount;
1418 ColCount := TStringGrid(FObject).ColCount;
1419
1420 for row := 0 to RowCount - 1 do
1421 begin
1422 DataTemp := '';
1423 for col := 0 to ColCount - 1 do
1424 begin
1425 DataTemp := DataTemp + TStringGrid(FObject).Cells[ col, row ];
1426 if col < ColCount - 1 then
1427 DataTemp := DataTemp + #9;
1428 end;
1429
1430 Data := Data + DataTemp + #13;
1431 end;
1432
1433 //OutputDebugString( PChar( 'TIStringGridDispatch.GetData Returing: ' + Data + #13#10 ) );
1434 Result := Data;
1435 end;
1436
1437 { TITreeViewDispatch }
1438
1439 procedure TITreeViewDispatch.GetPropNames(var v: Variant);
1440 begin
1441 inherited GetPropNames(v);
1442 end;
1443
1444 function TITreeViewDispatch.GetProperty(PropName: String): Variant;
1445 var
1446 Count: Integer;
1447 I: Integer;
1448 Holder: Variant;
1449 Nodes: TTreeNodes;
1450 Node, NodeTemp: TTreeNode;
1451 NodePath: string;
1452 begin
1453 //OutputDebugString( PChar( 'TITreeViewDispatch.GetProperty : ' + PropName + #13#10) );
1454 if Propname = 'Items' then
1455 begin
1456 Nodes := TTreeView(FObject).Items;
1457 Count := Nodes.Count;
1458 Holder := VarArrayCreate([0, Count-1], varOleStr);
1459 for I := 0 to Count - 1 do
1460 begin
1461 Node := Nodes.Item[ I ];
1462 NodeTemp := Node.Parent;
1463 NodePath := Node.Text;
1464
1465 while( NodeTemp <> nil ) do
1466 begin
1467 NodePath := NodeTemp.Text + '->' + NodePath;
1468 NodeTemp := NodeTemp.Parent;
1469 end;
1470 Holder[I] := Copy( NodePath, 0, MaxStringItem);
1471 end;
1472 Result := Holder;
1473 end
1474 else
1475 Result := inherited GetProperty(PropName);
1476 end;
1477
1478 { TIControlDispatch }
1479
1480 function TIControlDispatch.GetParent: Variant;
1481 begin
1482 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TControl(FObject).Parent)
1483 end;
1484
1485 {TIWinControlDispatch}
1486
1487 function TIWinControlDispatch.GetControls(Index: Integer): Variant;
1488 begin
1489 if (Index >= 0) and (Index < TWinControl(FObject).ControlCount) then
1490 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TWinControl(FObject).Controls[Index])
1491 else
1492 ;
1493 // OleError(DISP_E_BADINDEX);
1494 end;
1495
1496 function TIWinControlDispatch.GetHandle: Integer;
1497 begin
1498 Result := TWinControl(FObject).Handle;
1499 end;
1500
1501 function TIWinControlDispatch.GetControlCount: Integer;
1502 begin
1503 Result := TWinControl(FObject).ControlCount;
1504 end;
1505
1506 function TIWinControlDispatch.ControlAtPos(X, Y: Integer): Variant;
1507 var
1508 Pt: TPoint;
1509 Control: TControl;
1510 begin
1511 Pt.y := Y;
1512 Pt.x := X;
1513 Control := TWinControl(FObject).ControlAtPos(Pt, True);
1514 if Control <> nil then
1515 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Control)
1516 else
1517 ;
1518 // OleError(DISP_E_BADINDEX);
1519 end;
1520
1521 { TIApplicationDispatch }
1522
1523 constructor TIApplicationDispatch.Create;
1524 begin
1525 FObject := Application;
1526 inherited Create;
1527 end;
1528
1529 function TIApplicationDispatch.GetDispFromHandle(Handle: Integer): Variant;
1530 var
1531 Obj: TObject;
1532 begin
1533 Obj := FindControl(Handle);
1534 if (Obj <> nil) then
1535 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Obj)
1536 else
1537 ;
1538 // OleError(DISP_E_PARAMNOTFOUND);
1539 end;
1540
1541 function TIApplicationDispatch.GetHandle: Integer;
1542 begin
1543 Result := TApplication(FObject).Handle;
1544 end;
1545
1546 function TIApplicationDispatch.GetExeName: String;
1547 begin
1548 Result := TApplication(FObject).ExeName;
1549 end;
1550
1551 function TIApplicationDispatch.GetMainForm: Variant;
1552 begin
1553 TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TApplication(FObject).MainForm);
1554 end;
1555
1556 procedure RegisterAutomationServer;
1557 const
1558 AutoClassInfo: TAutoClassInfo = (
1559 AutoClass: TIApplicationDispatch;
1560 ProgID: 'SQAServer.Application';
1561 ClassID: '{92E4FBC0-1169-11D0-B5AB-00A02484352C}';
1562 Description: 'SQA Test Automation Server';
1563 Instancing: acMultiInstance);
1564 begin
1565 Automation.RegisterClass(AutoClassInfo);
1566 end;
1567
1568 function GetPropertyName : string;
1569 var
1570 propName : string;
1571 begin
1572 Result := 'SQAApplicationObject';
1573 if ( System.IsLibrary ) then
1574 begin
1575 propName := Format( 'SQAApplicationObject_%x', [ HInstance ] );
1576 Result := propName;
1577 end;
1578 end;
1579
1580 function GetApplicationHandle: THandle;
1581 var
1582 appHandle : THandle;
1583 begin
1584
1585 Result := Application.Handle;
1586 if ( Result = 0 ) then
1587 begin
1588 appHandle := FindWindow( PChar( 'TApplication' ), nil );
1589 Result := appHandle;
1590 end;
1591 end;
1592
1593 procedure BeautifyApplicationWindow;
1594 var
1595 appD : TIApplicationDispatch;
1596 propName : string;
1597 aut : TAutoDispatch;
1598 V : ^Variant;
1599 appHandle : THandle;
1600 begin
1601 propName := GetPropertyName( );
1602 appHandle := GetApplicationHandle( );
1603 //OutputDebugString( PChar( Format( 'DEEnabler: Application handle :<%x>' + #13#10, [ appHandle ] ) ) );
1604
1605 if ( GetProp( appHandle, PChar(propName) ) = 0 ) then
1606 begin
1607
1608 New( V );
1609 VarClear( V^ );
1610 appD := TIApplicationDispatch.Create( );
1611 aut := appD.AutoDispatch;
1612
1613 TVarData(V^).VType := varDispatch;
1614 TVarData(V^).VDispatch := aut;
1615 //VarToInterface(V^).AddRef;
1616
1617 //OutputDebugString( PChar( Format( 'DEEnabler: SetProp <%s> apphandle <%x> object <%x>' + #13#10, [ PChar(propName), appHandle, THandle( V ) ] ) ) );
1618 SetProp( appHandle, PChar(propName), THandle( V ) );
1619 end;
1620 end;
1621
1622 procedure RevertApplicationWindowChanges;
1623 var
1624 th : THandle;
1625 V : PVariant;
1626 propName : PChar;
1627 appHandle : THandle;
1628 begin
1629 propName := 'SQAApplicationObject';
1630
1631 appHandle := GetApplicationHandle();
1632 th := Windows.GetProp( appHandle, propName );
1633 if ( th <> 0 ) then
1634 begin
1635 V := PVariant(th);
1636 Dispose( V );
1637 //VarToInterface(V^).Release;
1638 Windows.RemoveProp( appHandle, propName );
1639 end;
1640 end;
1641
1642 function TIApplicationDispatch.FindControl1(hWndToFind: HWnd): TWinControl;
1643 var
1644 lControlAtom: TAtom;
1645 lControlAtomString: string;
1646 lOwningProcess: Pointer;
1647 lUnknownProcess: DWORD;
1648 lRM_GetObjectInstance: DWORD;
1649 begin
1650
1651 Result := nil;
1652 if (hWndToFind <> 0) then
1653 begin
1654 lControlAtomString := Format('ControlOfs%.8X%.8X', [GetWindowLong( hWndToFind, GWL_HINSTANCE), GetCurrentThreadID]);
1655 lControlAtom := GlobalAddAtom(PChar(lControlAtomString));
1656
1657 if GlobalFindAtom(PChar(lControlAtomString)) = lControlAtom then
1658 begin
1659 Result := Pointer(GetProp(hWndToFind, MakeIntAtom(lControlAtom)))
1660 end
1661 else
1662 begin
1663 lRM_GetObjectInstance := RegisterWindowMessage(PChar(lControlAtomString));
1664
1665 lOwningProcess := nil;
1666 GetWindowThreadProcessID(hWndToFind, lOwningProcess);
1667
1668 lUnknownProcess := GetCurrentProcessID();
1669 if DWORD(lOwningProcess) = lUnknownProcess then
1670 begin
1671 Result := Pointer(SendMessage(hWndToFind, lRM_GetObjectInstance, 0, 0))
1672 end
1673 else
1674 begin
1675 Result := nil;
1676 end;
1677 end;
1678 end;
1679 end;
1680
1681 begin
1682 RegisterAutomationEnabler(TObject, TIObjectDispatch);
1683 RegisterAutomationEnabler(TComponent, TIComponentDispatch);
1684 RegisterAutomationEnabler(TControl, TIControlDispatch);
1685 RegisterAutomationEnabler(TWinControl, TIWinControlDispatch);
1686 // SJP: Added 07/01/96.
1687 RegisterAutomationEnabler(TCollection, TICollectionDispatch);
1688 // SJP: Added 07/08/96.
1689 RegisterAutomationEnabler(TDataSet, TIDataSetDispatch);
1690 // SJP: Added 07/08/96.
1691 RegisterAutomationEnabler(TStrings, TIStringsDispatch);
1692 // SJP: Added 08/04/96.
1693 RegisterAutomationEnabler(TOleControl, TIOleControlDispatch);
1694 // SJP: Added 03/12/97.
1695 RegisterAutomationEnabler(TStringGrid, TIStringGridDispatch);
1696 // TreeView support
1697 RegisterAutomationEnabler(TTreeView, TITreeViewDispatch);
1698
1699 //RegisterAutomationServer;
1700 BeautifyApplicationWindow( );
1701 end.
1702
Note: See TracBrowser for help on using the repository browser.