{************************************************************************* * * Copyright 2000 - 2004 Rational Software Corporation. All Rights Reserved. * This software contains proprietary and confidential information of Rational * and its suppliers. Use, disclosure or reproduction is prohibited * without the prior express written consent of Rational. * * Name: sqasrvr.pas * Description: * * Revision History: * Programmer Date Description * sraj 05/18/2004 Fixed Delphi 5 compilation issues. * sraj 07/25/2003 Supported TTreeView items collection in properties. * sraj 07/25/2003 Supported TStringGrid object data. * sraj 24/04/2003 RATLC00447073: Included FindControl1() to lookup delphi object * given a window handle effectively. * sraj 10/03/2002 RATLC00436896, RATLC00052492 : Included BeautifyApplicationWindow * sraj 06/23/2003 RATLC00449186 : Exception trace enabled using a Registry key. * sraj 10/03/2002 RATLC00436896, RATLC00052492 : Included BeautifyApplicationWindow * to make application object available as a window property. * Removed the call RegisterAutomationServer() from unit Initialization. * PBeaulieu 01/08/2002 Changed TPublishedAutoDispatch.NewDispatch to set the found * flag if found in first case to bypass the second search method. * PBeaulieu 08/20/2001 Changed TIObjectDispatch.GetProperty inorder to make * sure that Unassigned Variant or incorrect Variant type * would not be used in retrieving a property. Changed * TPublishedAutoDispatch.NewDispatch to search manually the * inheritance hierarchy if InheritsFrom fails. This allows * for objects that the InheritsFrom function fails on * seemingly because it cannot access the information with * the functions it is using. This seemed to happen with * MDI app where the MDI children were created from another * dll that encapsulated the form in another object. * PBeaulieu 06/26/01 Merged in Pete Ness's changes to fix some warnings and * to add some logging for exceptions. Also, added the function * TIObjectDispatch.ParentClassName. * PMNess 05/16/01 Changed the "Classname" calls in TPublishedAutoDispatch * to FObject.Classname - as Classname was always * returning TPublishedAutoDispatch instead of * the actual invoked class. * PMNess 05/15/01 Updated and removed hints/warnings under D5 * Added try/excepts around all automated calls * to trap exceptions that may happen and log to * file. * KPATEL 05/25/00 Replaced the function 'VarAsType' with * 'VarToStr' as Delphi 5 takes only string as * the third parameter in SetStrProp function. * SJPak 03/31/98 Modified TIObjectDispatch.GetEnumList to * return empty variant when the total length of * the strings for enumerated choices exceed * 2047. This is to keep Robot from crashing * Robot cannot handle more 2048 characters total. * SJPak 04/02/97 Modified TPublishedAutoDispatch.Invoke to * support TColor type properties. * SJPak 08/04/96 Added additional interface TIStringGridDispatch * to support Cols and Rows properties of TStringGrid. * SJPak 03/06/97 Modified TICollectionDispatch.GetPropNames * and TICollectionDispatch.GetProperty to support * Items property. * SJPak 11/21/96 Replacing calls to OLECheck which * will raise an exception when return value * is less than 0. Raising an exception * will cause a messagebox to pop up when ran * from Delphi IDE. * SJPak 11/15/96 Fixed a memory leak in * TIObjectDispatch.SetProperty * SJPak 11/11/96 Modified TIStringsDispatch.GetProperty * to check for empty "Strings" property. * SJPak 11/07/96 Removed calls to OleError to prevent * error messages being displayed during * Rec/Plaback session through IDE. * SJPak 10/07/96 Modified TIStringsDispatch to support * Strings property of TStrings object. * SJPak 09/19/96 Changed CLSID of the server. * SJPak 08/04/96 Added additional interface TIOleControlDispatch * to support OCXs. * SJPak 08/01/96 Modified TPublishedAutoDispatch.Invoke * to return tkSet type properties as * a safe array of Variants containing * names of all possible items in the set * and booleans representing whether the items * are in the particular set. * SJPak 07/31/96 Fixed Borland's bug in * TPublishedAutoDispatch.Invoke function's * handling of min and max values of * tkSet properties. * SJPak 07/18/96 Changed Unit name to SQASrvr * SJPak 07/18/96 Added addtional interface TIStringsDispatch * to support TStrings class. * SJPak 07/18/96 Added GetPropNames and GetProeprty to * TICollectionDispatch. * SJPak 07/18/96 Added GetPropNames method to TIObjectDispatch * interface. * SJPak 07/08/96 Added SetProperty method to TIObjectDispatch * interface. * SJPak 07/08/96 Additional interface define for * DatSet Objects. * SJPak 07/01/96 Fixed a bug in TPublishedAutoDispatch.Invoke * SJPak 07/01/96 Additional interface defined for * collections. * SJPak 07/01/96 Original From Delphi. * **************************************************************************} unit SQASrvr; interface uses Windows, {$IFDEF VER140} Variants, {$ENDIF} {$IFDEF VER150} Variants, {$ELSE} //Added for Delphi 2006 Variants, //Added for Delphi 2006 {$ENDIF} OleAuto, OLE2, TypInfo, DB, DBTables, OleCtrls, Grids, Controls, Registry, ComCtrls; const AutoClassExistsMsg = 'Automation enabler for class %s is already registered'; { FirstComponentIndex needs to be high enough so that it doesn't conflict with the DispIDs of the TAutoObject. The "automated" properties and methods have DispIDs starting with 1 in the base object and incrementing by one from there. } FirstComponentIndex = $000000FF; LastComponentIndex = $0000FFFE; FirstPropIndex = $0000FFFF; LastPropIndex = $7FFFFFFF; { maxint } // Arbitrary Max for each element of TStrings.Strings property. MaxStringItem = 32000; type { SJP Todo: This limits the set range from 0 - 15. According to Doc. Set can have upto 256 elements } TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1; // TCardinalSet = set of 0..255; { TPublishedAutoDispatch } TPublishedAutoDispatch = class(TAutoDispatch) private FObject: TObject; public constructor Create(AutoObject: TAutoObject; BoundObj: TObject); procedure NewDispatch(var V: Variant; Obj: TObject); function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList; cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override; function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID; flags: Word; var dispParams: TDispParams; varResult: PVariant; excepInfo: PExcepInfo; argErr: PInteger): HResult; override; end; { TIObjectDispatch } TIObjectDispatch = class(TAutoObject) private procedure GetProps(var v: Variant; TypeKinds: TTypeKinds); protected FObject: TObject; function CreateAutoDispatch: TAutoDispatch; override; // 5/16/2001 - PMNess - Added new GetExceptionInfo to log any // exception on the invoke to a log file. This works generically when anything // is called... procedure GetExceptionInfo(ExceptObject: TObject; var ExcepInfo: TExcepInfo); override; public constructor Connect(Obj: TObject); virtual; automated function ClassName: String; function GetProperty(PropName: String): Variant; function GetObject(ObjName: String): Variant; procedure GetEnumList(PropName: String; var v: Variant); procedure GetProperties(var v: Variant); procedure GetObjects(var v: Variant); function InheritsFrom(AClass: String): WordBool; // SJP: 07/09/96 Added SetProperty. function SetProperty(PropName: String; var v: Variant): WordBool; // SJP: 07/18/96 Added SetProperty. procedure GetPropNames(var v: Variant); //PBeaulieu: 05/22/2001 Added ParentClassName function ParentClassName: String; end; { TIComponentDispatch } TIComponentDispatch = class(TIObjectDispatch) private function GetComponents(Index: Integer): Variant; function GetComponentCount: Integer; function GetComponentIndex: Integer; function GetOwner: Variant; protected // 5-16-2001 - Added protected to get rid of hint on GetDesignInfo function GetDesignInfo: LongInt; automated property Components[Index: Integer]: Variant read GetComponents; property ComponentCount: Integer read GetComponentCount; property ComponentIndex: Integer read GetComponentIndex; property Owner: Variant read GetOwner; function FindComponent(AName: String): Variant; end; { TIControlDispatch } TIControlDispatch = class(TIComponentDispatch) private function GetParent: Variant; automated property Parent: Variant read GetParent; end; { TIWinControlDispatch } TIWinControlDispatch = class(TIControlDispatch) private function GetHandle: Integer; function GetControls(Index: Integer): Variant; function GetControlCount: Integer; automated property Handle: Integer read GetHandle; property Controls[Index: Integer]: Variant read GetControls; property ControlCount: Integer read GetControlCount; function ControlAtPos(X, Y: Integer): Variant; end; { TIApplicationDispatch } TIApplicationDispatch = class(TIComponentDispatch) private function GetHandle: Integer; function GetMainForm: Variant; function GetExeName: String; function FindControl1(hWndToFind: HWnd): TWinControl; public constructor Create; override; automated property Handle: Integer read GetHandle; property MainForm: Variant read GetMainForm; property ExeName: String read GetExeName; function GetDispFromHandle(Handle: Integer): Variant; end; // SJP 07/01/96 Additional interface defined for collections { TICollectionDispatch } TICollectionDispatch = class(TIObjectDispatch) private function GetItemCount: Integer; automated property ItemCount: Integer read GetItemCount; procedure GetPropNames(var v: Variant); function GetProperty(PropName: String): Variant; end; // SJP 07/08/96 Additional interface defined for 'dataset' objects. { TIDataSetDispatch } TIDataSetDispatch = class(TIObjectDispatch) private function GetFieldCount: Integer; automated property FieldCount: Integer read GetFieldCount; function GetData: String; end; // SJP 07/18/96 Additional interface defined for TStrings Objects { TIStringsDispatch } TIStringsDispatch = class(TIObjectDispatch) automated function GetProperty(PropName: String): Variant; procedure GetPropNames(var v: Variant); end; // SJP 08/03/96 Addition interface defined for TOleControl(OCX) Component TIOleControlDispatch = class(TIWinControlDispatch) private function GetOleObject: Variant; automated property OleObject: Variant read GetOleObject; end; // SJP 03/10/97 Addition interface defined for TStringGrid Component TIStringGridDispatch = class(TIWinControlDispatch) automated function GetProperty(PropName: String): Variant; procedure GetPropNames(var v: Variant); function GetData: String; end; // Addition interface defined for TTreeView Component TITreeViewDispatch = class(TIWinControlDispatch) automated function GetProperty(PropName: String): Variant; procedure GetPropNames(var v: Variant); end; { Support functions} TIObjectDispatchRef = class of TIObjectDispatch; PClassMapRecord = ^TClassMapRecord; TClassMapRecord = record ObjectClass: TClass; DispClass: TIObjectDispatchRef; end; procedure FreeClassLists; procedure RegisterAutomationEnabler( ObjectClass: TClass; DispClass: TIObjectDispatchRef); implementation uses Forms, Classes, SysUtils; var ClassMap: TList = nil; // Called when any exception is raised from this COM object. Logs the // error to a log file. procedure WriteToLog(ErrorMsg: String); var LogFile: TextFile; LogFileName: String; begin // AddToErrorLog try LogFileName := ExtractFilePath(ParamStr(0))+'\Robot Errors for '+ExtractFileName(ParamStr(0))+'.log'; AssignFile(LogFile, LogFileName); if (FileExists(LogFileName)) then Append(LogFile) else Rewrite(LogFile); try Writeln(LogFile, DateTimeToStr(Now)+' '+ErrorMsg); finally CloseFile(LogFile); end; except // Supress this - as we're likely in some kind of error log already! end; end; function IsExceptionTraceEnabled( ) : Boolean; var Reg: TRegistry; deTrace: string; begin Result := False; Reg := TRegistry.Create; try Reg.RootKey := HKEY_CURRENT_USER; if Reg.OpenKey('Software\Rational Software\Rational Test\8\Robot', False) then begin deTrace := Reg.ReadString( 'DelphiExceptionTrace' ); if ( (deTrace = '1') or ( LowerCase(deTrace) = 'true' ) ) then begin Result := True; end; Reg.CloseKey; end; finally Reg.Free; end; end; { Exit procedure used to free memory used by the ClassList } procedure FreeClassLists; var I: Integer; begin for I := 0 to ClassMap.Count-1 do Dispose(PClassMapRecord(ClassMap[I])); ClassMap.Free; end; { This is called in the initialization section of a unit for all new automation objects. It associates an AutoObject with a VCL class. } procedure RegisterAutomationEnabler(ObjectClass: TClass; DispClass: TIObjectDispatchRef); var P: PClassMapRecord; X: Integer; Found: Boolean; begin if not Assigned(ClassMap) then begin AddExitProc(FreeClassLists); ClassMap := TList.Create; end; Found := False; for X := 0 to ClassMap.Count-1 do begin P := PClassMapRecord(ClassMap[x]); if ObjectClass.InheritsFrom(P^.ObjectClass) then if ObjectClass = P^.ObjectClass then raise Exception.CreateFmt(AutoClassExistsMsg,[ObjectClass.ClassName]) else begin Found := True; break; end; end; New(P); P^.ObjectClass := ObjectClass; P^.DispClass := DispClass; if Found then { ObjectClass is a descendent of P^.ObjectClass, so insert the descendent into the class list in front of the ancestor. } ClassMap.Insert(X,P) else { ObjectClass is not related to any classes already in the list, so just add it to the end of the list. } ClassMap.Add(P); end; { TPublishedAutoDispatch } constructor TPublishedAutoDispatch.Create(AutoObject: TAutoObject; BoundObj: TObject); begin inherited Create(AutoObject); FObject := BoundObj; end; { NewDispatch is called to create an AutoObject bound to a VCL object. Example: when the controller calls Application.MainForm.Button1.Caption, NewDispatch would be called to return the dispatches for MainForm and Button1. Not called directly by the controller. } procedure TPublishedAutoDispatch.NewDispatch(var V: Variant; Obj: TObject); var i: Integer; P: PClassMapRecord; Found: Boolean; Cls: TClass; begin VarClear(V); Found := FALSE; if not (Assigned(Obj) and Assigned(ClassMap)) then Exit; for i := 0 to ClassMap.Count - 1 do begin P := PClassMapRecord(ClassMap[i]); if Obj.InheritsFrom(P^.ObjectClass) then begin V := P^.DispClass.Connect(Obj).OleObject; { Do a release here because the Connect does an AddRef and the OleObject does an AddRef, we only want 1. } VarToInterface(V).Release; Found := TRUE; break; end; end; if Found = FALSE then begin for i := 0 to ClassMap.Count - 1 do begin P := PClassMapRecord(ClassMap[i]); if Obj.ClassName = P^.ObjectClass.ClassName then begin V := P^.DispClass.Connect(Obj).OleObject; { Do a release here because the Connect does an AddRef and the OleObject does an AddRef, we only want 1. } VarToInterface(V).Release; break; end; Cls := Obj.ClassParent; while( Cls <> nil ) do begin if Cls.ClassName = P^.ObjectClass.ClassName then begin V := P^.DispClass.Connect(Obj).OleObject; { Do a release here because the Connect does an AddRef and the OleObject does an AddRef, we only want 1. } VarToInterface(V).Release; Found := TRUE; break; end; Cls := Cls.ClassParent; end; if Found = TRUE then begin break; end; end; end; end; { Searches through the published properties of the associated object for the requested name (property). If it is not found it calls the inherited GetIDsOfNames which will then search through the TAutoObject's "automated" section for the name. } function TPublishedAutoDispatch.GetIDsOfNames(const iid: TIID; rgszNames: POleStrList; cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; var PropName: string; SubComponent: TComponent; begin if cNames <> 1 then begin Result := inherited GetIDsOfNames(iid, rgszNames, cNames, lcid, rgdispid); Exit; end; Result := DISP_E_UNKNOWNNAME; PropName := WideCharToString(rgszNames^[0]); rgdispid^[0] := TDISPID(GetPropInfo(FObject.ClassInfo, PropName)); if rgdispid^[0] <> 0 then begin if PPropInfo(rgdispid^[0])^.PropType^.Kind in [tkInteger, tkEnumeration, tkString, tkFloat, tkClass, tkSet, tkMethod, tkLString{, tkLWString}] then Result := S_OK; end else if FObject is TComponent then begin SubComponent := TComponent(FObject).FindComponent(PropName); if SubComponent <> nil then begin rgdispid^[0] := FirstComponentIndex + TDispID(SubComponent.ComponentIndex); Result := S_OK; end; end; { Pass to inherited if nothing resolves the call. } if Result <> S_OK then Result := inherited GetIDsOfNames(iid, rgszNames, cNames, lcid, rgdispid); end; { Gets a property or calls a method of the associated object. If the dispIDMember is less than FirstComponentIndex it should be in the AutoObject, otherwise it attempts to find the request in the published section of the associated object. } function TPublishedAutoDispatch.Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID; flags: Word; var dispParams: TDispParams; varResult: PVariant; excepInfo: PExcepInfo; argErr: PInteger): HResult; var PropInfo: PPropInfo; W: Cardinal; TypeInfo: PTypeInfo; TypeData: PTypeData; ErrorMessage: String; I: Integer; J: Integer; // SetItemString: String; begin Result := DISP_E_MEMBERNOTFOUND; PropInfo := NIL; try { If it is a component then call NewDispatch to return the IDispatch to the controller } if (dispIDMember >= FirstComponentIndex) and (dispIDMember <= LastComponentIndex) then begin NewDispatch(VarResult^,TComponent(FObject).Components[dispIDMember - FirstComponentIndex]); Result := S_OK; end { Check to see if it is a property } else if (dispIDMember >= FirstPropIndex) then // and (dispIDMember <= LastPropIndex) 5-16-2001 Removed - as this is always true begin PropInfo := PPropInfo(dispIDMember); if Flags and DISPATCH_PROPERTYGET <> 0 then //Only Get Property begin VarClear(VarResult^); Result := S_OK; case PropInfo^.PropType^.Kind of tkInteger: begin VarResult^ := GetOrdProp(FObject, PropInfo); // SJP: 04/02/97 Modifying original. // Set a flag to indicate Color property. if PropInfo^.PropType^.Name = 'TColor' then begin TVariantArg(VarResult^).wReserved1 := 8; end; end; tkEnumeration: // SJP: 07/10/96 Modifying original. // Now tkEnumeration properties will // be returned as VT_I2; begin //TVariantArg(VarResult^).vt := VT_BSTR; //TVariantArg(VarResult^).bstrVal := StringToOleStr( //GetEnumName(PropInfo^.PropType, GetOrdProp(FObject, PropInfo))); TVariantArg(VarResult^).vt := VT_I2; TVariantArg(VarResult^).iVal := GetOrdProp(FObject, PropInfo); end; tkFloat: VarResult^ := GetFloatProp(FObject, PropInfo); tkString: VarResult^ := GetStrProp(FObject, PropInfo); tkSet: begin // SJP: 07/31/96 Modifying the original. // Changing to return a safe array of Variants containing // Names of all possible items in the set // and booleans representing whether the items are // in this particular set. // SetItemString := '['; W := GetOrdProp(FObject, PropInfo); {$IFDEF VER90} TypeData := GetTypeData(PropInfo^.PropType); TypeInfo := TypeData^.CompType; {$ELSE} TypeData := GetTypeData(PropInfo^.PropType^); TypeInfo := TypeData^.CompType^; {$ENDIF} // SJP: 07/31/96 Modifying the original Borland code. // Get the TypeData again from the TypeInfo // TypeInfo represents the OrdType of the set. // the new TypeData will have correct MinValue and MaxValue. TypeData := GetTypeData(TypeInfo); VarResult^ := VarArrayCreate([0, TypeData^.MaxValue - TypeData^.MinValue, 0, 1], varVariant); J := 0; for I := TypeData^.MinValue to TypeData^.MaxValue do begin VarResult^[J, 0] := GetEnumName(TypeInfo, I); if I in TCardinalSet(W) then VarResult^[J, 1] := True else VarResult^[J, 1] := False; J := J + 1; end; // begin // if Length(SetItemString) <> 1 then // SetItemString := SetItemString + ','; // SetItemString := SetItemString + GetEnumName(TypeInfo, I); // end; // SetItemString := SetItemString + ']'; // TVariantArg(VarResult^).vt := VT_BSTR; // TVariantArg(VarResult^).bstrVal := StringToOleStr(SetItemString); end; tkClass: NewDispatch(VarResult^, TObject(GetOrdProp(FObject, PropInfo))); tkLString: begin TVariantArg(VarResult^).vt := VT_BSTR; TVariantArg(VarResult^).bstrVal := StringToOleStr(GetStrProp(FObject, PropInfo)); end; else Result := E_NOTIMPL; end; end else if Flags and DISPATCH_PROPERTYPUT <> 0 then begin Result := S_OK; case PropInfo^.PropType^.Kind of tkInteger: SetOrdProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varInteger)); tkString: // KPATEL: Replaced the function 'VarAsType' with 'VarToStr' as Delphi 5 // takes only string as the third parameter in SetStrProp function. // SetStrProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varString)); SetStrProp(FObject, PropInfo, VarToStr(Variant(dispParams.rgvarg[0]))); tkLString: // KPATEL: Replaced the function 'VarAsType' with 'VarToStr' as Delphi 5 // takes only string as the third parameter in SetStrProp function. // SetStrProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varString)); SetStrProp(FObject, PropInfo, VarToStr(Variant(dispParams.rgvarg[0]))); tkEnumeration: SetOrdProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varSmallInt)); tkFloat: SetFloatProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varSingle)); { tkSet: begin SetItemString := '['; W := GetOrdProp(FObject, PropInfo); TypeData := GetTypeData(PropInfo^.PropType); TypeInfo := TypeData^.CompType; // SJP: Commented out because TypeData^.MinValue/MaxValue is // bogus. // ShowMessage(IntToStr(TypeData^.MinValue)); // ShowMessage(IntToStr(TypeData^.MaxValue)); // for I := TypeData^.MinValue to TypeData^.MaxValue do for I := 0 to 255 do if I in TCardinalSet(W) then begin if Length(SetItemString) <> 1 then SetItemString := SetItemString + ','; SetItemString := SetItemString + GetEnumName(TypeInfo, I); end; SetItemString := SetItemString + ']'; TVariantArg(VarResult^).vt := VT_BSTR; TVariantArg(VarResult^).bstrVal := StringToOleStr(SetItemString); end;} else Result := E_NOTIMPL; end; end; end; { If not found then pass it to the TAutoDispatch.Invoke method. } if Result <> S_OK then begin Result := inherited Invoke(dispIDMember, iid, lcid, flags, dispParams, varResult, excepInfo, argErr); end except on E:Exception do begin ErrorMessage := FObject.ClassName; if (Assigned(PropInfo)) then ErrorMessage := ErrorMessage + '.' + PropInfo.Name; if ExcepInfo <> nil then begin FillChar(ExcepInfo^, 0, SizeOf(TExcepInfo)); //Copied this from TAutoObject.GetExceptionInfo with ExcepInfo^ do begin bstrSource := StringToOleStr(FObject.ClassName); if ExceptObject is Exception then begin bstrDescription := StringToOleStr(Exception(ExceptObject).Message); ErrorMessage := ErrorMessage + ': ' + Exception(ExceptObject).Message; end else ErrorMessage := ErrorMessage + ': ' + E.Message; scode := E_FAIL; end; end else ErrorMessage := ErrorMessage + ': ' + E.Message; WriteToLog(ErrorMessage); Result := DISP_E_EXCEPTION; end; end; end; { TIObjectDispatch } { Obj is the Object that is being "Bound" to here. This AutoObject will then surface properties for Obj. } constructor TIObjectDispatch.Connect(Obj: TObject); begin FObject := Obj; inherited Create; end; function TIObjectDispatch.CreateAutoDispatch: TAutoDispatch; begin Result := TPublishedAutoDispatch.Create(Self, FObject); end; // New override to trap exceptions raised in the invoke. // 5/16/2001 - PMNess procedure TIObjectDispatch.GetExceptionInfo(ExceptObject: TObject; var ExcepInfo: TExcepInfo); begin try if (ExceptObject is Exception) then begin WriteToLog(PChar(Exception(ExceptObject).Message)); end; except // 5/16/2001 - PMNess // If the exception object has a problem, we don't want to cause another // exception here, so just mask it. end; inherited; end; function TIObjectDispatch.ClassName: String; begin Result := FObject.ClassName; end; function TIObjectDispatch.ParentClassName: String; var P: TClass; ClassNames: String; begin P := FObject.ClassParent; ClassNames := ''; while( P <> nil ) do begin if Length(ClassNames) > 0 then begin ClassNames := ClassNames + ','; end; ClassNames := ClassNames + P.ClassName; P := P.ClassParent; end; Result := ClassNames; end; function TIObjectDispatch.InheritsFrom(AClass: String): WordBool; var P: TClass; begin P := FObject.ClassType; while (P <> nil) and (CompareText(P.ClassName, AClass) <> 0) do P := P.ClassParent; Result := P <> nil; end; { Just a friendly wrapper around GetProperty for ease of use } function TIObjectDispatch.GetObject(ObjName: String): Variant; begin Result := GetProperty(ObjName); end; { GetProperty can take a full path to a property or object (ie Form1.Button1.Caption) and return the value of the property or object as a variant. } function TIObjectDispatch.GetProperty(PropName: String): Variant; var Params: TDispParams; Index: TDISPID; ExpInfo: TEXCEPINFO; ArgErr: Integer; PWStr: PWideChar; Name: String; Idx: Integer; Holder: Variant; guid: TGUID; begin FillChar(Params,SizeOf(Params),0); FillChar(ExpInfo,SizeOf(ExpInfo),0); ArgErr := 0; Idx := Pos('.', PropName); if Idx > 0 then begin Name := Copy(PropName,1,Idx - 1); Delete(PropName,1,Idx); end else Name := PropName; PWStr := StringToOleStr(Name); // 11/21/96 SJPak Replacing calls to OLECheck which will raise an exception // when return value is less than 0. Raising an exception // will cause a messagebox to pop up when ran from IDE. if AutoDispatch.GetIDsOfNames(guid, @PWStr, 1, 0, @Index) >= 0 then if AutoDispatch.Invoke(Index, guid, 0, Dispatch_PropertyGet or Dispatch_Method, Params, @Holder, @ExpInfo, @ArgErr) >= 0 then if VarType(Holder) = varDispatch then VarToInterface(Holder).AddRef; SysFreeString(PWStr); if ( not VarIsEmpty( Holder ) ) and ( VarType( Holder ) = varDispatch ) and ( Idx > 0 ) then begin Result := Holder.GetProperty(PropName); VarToInterface(Holder).Release; VarClear(Holder); end else if ( VarIsEmpty( Holder ) ) then begin Holder := NULL; // VarClear( Holder ); Result := Holder; end else Result := Holder; end; procedure TIObjectDispatch.GetProps(var v: Variant; TypeKinds: TTypeKinds); var I, J, Count: Integer; PropInfo: PPropInfo; TempList: PPropList; SetItemString: String; W: Cardinal; begin Count := GetPropList(FObject.ClassInfo, TypeKinds, nil); if Count > 0 then begin v := VarArrayCreate([0, Count - 1, 0, 2], varVariant); GetMem(TempList, Count * SizeOf(Pointer)); try GetPropList(FObject.ClassInfo, TypeKinds, TempList); for I := 0 to Count - 1 do begin PropInfo := TempList^[I]; v[i,2] := PropInfo^.PropType^.Kind; case PropInfo^.PropType^.Kind of tkClass: begin v[i,0] := PropInfo^.Name; v[i,1] := '(' + PropInfo^.PropType^.Name + ')'; end; tkString, tkLString: begin v[i,0] := PropInfo^.Name; v[i,1] := GetStrProp(FObject,PropInfo); end; tkChar: begin v[i,0] := PropInfo^.Name; v[i,1] := Chr(GetOrdProp(FObject,PropInfo)); if IsCharAlpha(Chr(GetOrdProp(FObject,PropInfo))) then v[i,1] := Chr(GetOrdProp(FObject,PropInfo)) else v[i,1] := '#' + IntToStr(GetOrdProp(FObject,PropInfo)); end; tkInteger: begin v[i,0] := PropInfo^.Name; v[i,1] := IntToStr(GetOrdProp(FObject,PropInfo)); end; tkFloat: begin v[i,0] := PropInfo^.Name; v[i,1] := FloatToStr(GetFloatProp(FObject,PropInfo)); end; tkEnumeration: begin v[i,0] := PropInfo^.Name; {$IFDEF VER90} v[i,1] := GetEnumName(PropInfo^.PropType, GetOrdProp(FObject, PropInfo)); {$ELSE} v[i,1] := GetEnumName(PropInfo^.PropType^, GetOrdProp(FObject, PropInfo)); {$ENDIF} end; tkSet: begin v[i,0] := PropInfo^.Name; SetItemString := '['; W := GetOrdProp(FObject, PropInfo); for J := 0 to 15 do if J in TCardinalSet(W) then begin if Length(SetItemString) <> 1 then SetItemString := SetItemString + ','; SetItemString := SetItemString + {$IFDEF VER90} GetEnumName(GetTypeData(PropInfo^.PropType)^.CompType, J); {$ELSE} GetEnumName(GetTypeData(PropInfo^.PropType^)^.CompType^, J); {$ENDIF} end; SetItemString := SetItemString + ']'; v[i,1] := SetItemString; end; tkVariant: try v[i,0] := PropInfo^.Name; v[i,1] := VarAsType(GetVariantProp(FObject,PropInfo), varString); except v[i,1] := '(Variant)'; end; //None of these area implemented... // tkWChar: // tkLWString: // tkUnknown: // tkMethod: end; end; finally FreeMem(TempList, Count * SizeOf(Pointer)); end; end; end; procedure TIObjectDispatch.GetProperties(var v: Variant); const TypeKinds: TTypeKinds = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, {tkMethod, }{tkWChar, }tkLString, {tkLWString,} tkVariant]; begin GetProps(v, TypeKinds); end; procedure TIObjectDispatch.GetObjects(var v: Variant); begin GetProps(v, [tkClass]); end; { Given the property name this will return an array containing the possible values of an enum. } procedure TIObjectDispatch.GetEnumList(PropName: String; var v: Variant); var Name: String; Idx: Integer; Obj: Variant; I, J: Integer; TotalLength: Integer; PropInfo: PPropInfo; TypeData: PTypeData; begin Idx := Length(PropName); while (Idx > 0) and (PropName[Idx] <> '.') do Dec(Idx); if Idx > 0 then begin Name := PropName; Delete(Name,1,Idx); Obj := GetProperty(Copy(PropName,1,Idx - 1)); try Obj.GetEnumList(Name,v); finally VarToInterface(Obj).Release; end; end else begin PropInfo := GetPropInfo(FObject.ClassInfo,PropName); if PropInfo^.PropType^.Kind <> tkEnumeration then raise EOleSysError(DISP_E_TYPEMISMATCH); {$IFDEF VER90} TypeData := GetTypeData(PropInfo^.PropType); {$ELSE} TypeData := GetTypeData(PropInfo^.PropType^); {$ENDIF} j := TypeData^.MaxValue - TypeData^.MinValue; v := VarArrayCreate([0, j], varVariant); j := 0; TotalLength := 0; for i := TypeData^.MinValue to TypeData^.MaxValue do begin {$IFDEF VER90} v[j] := GetEnumName(PropInfo^.PropType,i); {$ELSE} v[j] := GetEnumName(PropInfo^.PropType^,i); {$ENDIF} TotalLength := TotalLength + Length(v[j]) + 1; Inc(j); end; // SJP 3/31/98 Temporary fix to allow buffer overwrite in 6.1 SQAXDEL.DLL if TotalLength > 2047 then begin v := UnAssigned; end; end; end; // SJP: 07/09/96 Added SetProperty. function TIObjectDispatch.SetProperty(PropName: String; var v: Variant): WordBool; var Params: TDispParams; Index: TDISPID; ExpInfo: TEXCEPINFO; ArgErr: Integer; PWStr: PWideChar; Name: String; Idx: Integer; Obj: Variant; guid: TGUID; bSuccess: WordBool; begin bSuccess := True; // Separate the last property from the full path name. Idx := Length(PropName); while (Idx > 0) and (PropName[Idx] <> '.') do Dec(Idx); if Idx > 0 then begin Name := PropName; Delete(Name,1,Idx); Obj := GetProperty(Copy(PropName,1,Idx - 1)); try bSuccess := Obj.SetProperty(Name,v); finally VarToInterface(Obj).Release; end; end else begin FillChar(Params,SizeOf(Params),0); FillChar(ExpInfo,SizeOf(ExpInfo),0); ArgErr := 0; PWStr := StringToOleStr(PropName); New(Params.rgvarg); Params.rgvarg[0] := TVariantArg(v); params.cArgs := 1; // 11/21/96 SJPak Replacing calls to OLECheck which will raise an exception // when return value is less than 0. Raising an exception // will cause a messagebox to pop up when ran from IDE. if AutoDispatch.GetIDsOfNames(guid, @PWStr, 1, 0, @Index) >= 0 then begin if AutoDispatch.Invoke(Index, guid, 0, Dispatch_PropertyPut, Params, nil, @ExpInfo, @ArgErr) < 0 then bSuccess := False; end else bSuccess := False; SysFreeString(PWStr); Dispose(params.rgvarg); end; Result := bSuccess; end; // SJP: 07/18/96 Added. procedure TIObjectDispatch.GetPropNames(var v: Variant); const TypeKinds: TTypeKinds = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet, tkClass, {tkMethod, }{tkWChar, }tkLString, {tkLWString,} tkVariant]; var I, Count: Integer; PropInfo: PPropInfo; TempList: PPropList; begin Count := GetPropList(FObject.ClassInfo, TypeKinds, nil); if Count > 0 then begin v := VarArrayCreate([0, Count - 1, 0, 1], varVariant); GetMem(TempList, Count * SizeOf(Pointer)); try GetPropList(FObject.ClassInfo, TypeKinds, TempList); for I := 0 to Count - 1 do begin PropInfo := TempList^[I]; v[i,1] := PropInfo^.PropType^.Kind; case PropInfo^.PropType^.Kind of tkClass: v[i,0] := PropInfo^.Name; tkString, tkLString: v[i,0] := PropInfo^.Name; tkChar: v[i,0] := PropInfo^.Name; tkInteger: v[i,0] := PropInfo^.Name; tkFloat: v[i,0] := PropInfo^.Name; tkEnumeration: v[i,0] := PropInfo^.Name; tkSet: v[i,0] := PropInfo^.Name; tkVariant: v[i,0] := PropInfo^.Name; //None of these area implemented... // tkWChar: // tkLWString: // tkUnknown: // tkMethod: end; end; finally FreeMem(TempList, Count * SizeOf(Pointer)); end; end; end; { TIComponentDispatch } function TIComponentDispatch.GetComponents(Index: Integer): Variant; begin if (Index >= 0) and (Index < TComponent(FObject).ComponentCount) then TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TComponent(FObject).Components[Index]) else ; // OleError(DISP_E_BADINDEX); end; function TIComponentDispatch.GetComponentCount: Integer; begin Result := TComponent(FObject).ComponentCount; end; function TIComponentDispatch.GetComponentIndex: Integer; begin Result := TComponent(FObject).ComponentIndex; end; function TIComponentDispatch.GetOwner: Variant; begin TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TComponent(FObject).Owner) end; function TIComponentDispatch.GetDesignInfo: LongInt; begin Result := TComponent(FObject).DesignInfo; end; function TIComponentDispatch.FindComponent(AName: String): Variant; var Obj: TComponent; begin Obj := TComponent(FObject).FindComponent(AName); if Obj <> nil then TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Obj) else ; // OleError(DISP_E_UNKNOWNNAME); end; { TICollectionDispatch } function TICollectionDispatch.GetItemCount: Integer; begin Result := TCollection(FObject).Count; end; procedure TICollectionDispatch.GetPropNames(var v: Variant); var Count, I : Integer; vTemp : Variant; begin inherited GetPropNames(vTemp); Count := -1; if VarIsArray(vTemp) then Count := VarArrayHighBound(vTemp, 1); v := VarArrayCreate([0, Count + 2, 0, 1], varVariant); for I := 0 to Count do begin v[I, 0] := vTemp[I, 0]; v[I, 1] := vTemp[1, 1]; end; v[Count + 1, 0] := 'Count'; v[Count + 1, 1] := tkInteger; v[Count + 2, 0] := 'Items'; v[Count + 2, 1] := tkClass; VarClear(vTemp); end; function TICollectionDispatch.GetProperty(PropName: String): Variant; var Count: Integer; I: Integer; Item: Variant; Holder: Variant; begin if Propname = 'Count' then begin Holder := TCollection(FObject).Count; Result := Holder; end else if Propname = 'Items' then begin Count := TCollection(FObject).Count; Holder := VarArrayCreate([0, Count-1], varDispatch); for I := 0 to Count-1 do begin TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TCollection(FObject).Items[I]); Holder[I] := Item; end; Result := Holder; end else Result := inherited GetProperty(PropName); end; { TIDataSetDispatch } // SJP. 07/08/96 Returns FieldCount for TDataSet Objects. function TIDataSetDispatch.GetFieldCount: Integer; begin Result := TDataSet(FObject).FieldCount; end; // SJP. 07/08/96 Returns Tab-delimited/New-line separated // 'data' for TDataSet Objects. function TIDataSetDispatch.GetData: String; var I: Integer; Data: String; InitialBookMark: TBookMark; begin InitialBookMark := TDataSet(FObject).GetBookMark; Data := ''; TDataSet(FObject).First; while TDataSet(FObject).EOF = False do begin for I := 0 to TDataSet(FObject).FieldCount - 1 do begin if TDataSet(FObject).Fields[I].InheritsFrom(TMemoField) then Data := Data + '(Memo)' else if TDataSet(FObject).Fields[I].InheritsFrom(TGraphicField) then Data := Data + '(Graphic)' else if TDataSet(FObject).Fields[I].InheritsFrom(TBlobField) then Data := Data + '(Blob)' else if TDataSet(FObject).Fields[I].InheritsFrom(TBytesField) then Data := Data + '(Bytes)' else if TDataSet(FObject).Fields[I].InheritsFrom(TVarBytesField) then Data := Data + '(Var Bytes)' else Data := Data + TDataSet(FObject).Fields[I].AsString; if I < TDataSet(FObject).FieldCount - 1 then Data := Data + #9; end; TDataSet(FObject).Next; Data := Data + #13; end; TDataSet(FObject).GotoBookMark(InitialBookMark); TDataSet(FObject).FreeBookMark(InitialBookMark); Result := Data; end; { TIStringDispatch } procedure TIStringsDispatch.GetPropNames(var v: Variant); var Count, I : Integer; vTemp : Variant; begin inherited GetPropNames(vTemp); Count := -1; if VarIsArray(vTemp) then Count := VarArrayHighBound(vTemp, 1); v := VarArrayCreate([0, Count + 2, 0, 1], varVariant); for I := 0 to Count do begin v[I, 0] := vTemp[I, 0]; v[I, 1] := vTemp[1, 1]; end; v[Count + 1, 0] := 'Text'; v[Count + 1, 1] := tkString; v[Count + 2, 0] := 'Strings'; v[Count + 2, 1] := tkString; VarClear(vTemp); end; function TIStringsDispatch.GetProperty(PropName: String): Variant; var I: Integer; Count: Integer; Holder: Variant; begin if Propname = 'Strings' then begin Count := TStrings(FObject).Count; if Count > 0 then begin Holder := VarArrayCreate([0, Count-1], varOleStr); for I := 0 to Count-1 do begin // Arbitrary Max len of 32000 Holder[I] := Copy(TStrings(FObject).Strings[I], 0, MaxStringItem); end; end; Result := Holder; end else if Propname = 'Text' then begin Holder := TStrings(FObject).Text; Result := Holder; end else Result := inherited GetProperty(PropName); end; { TIOleControlDispatch } function TIOleControlDispatch.GetOleObject: Variant; begin Result := TOleControl(FObject).OleObject; end; { TIStringGridDispatch } procedure TIStringGridDispatch.GetPropNames(var v: Variant); var Count, I : Integer; vTemp : Variant; begin inherited GetPropNames(vTemp); Count := -1; if VarIsArray(vTemp) then Count := VarArrayHighBound(vTemp, 1); v := VarArrayCreate([0, Count + 2, 0, 1], varVariant); for I := 0 to Count do begin v[I, 0] := vTemp[I, 0]; v[I, 1] := vTemp[1, 1]; end; v[Count + 1, 0] := 'Cols'; v[Count + 1, 1] := tkClass; v[Count + 2, 0] := 'Rows'; v[Count + 2, 1] := tkClass; VarClear(vTemp); end; function TIStringGridDispatch.GetProperty(PropName: String): Variant; var Count: Integer; I: Integer; Item: Variant; Holder: Variant; begin if Propname = 'Cols' then begin Count := TStringGrid(FObject).ColCount; Holder := VarArrayCreate([0, Count-1], varDispatch); for I := 0 to Count-1 do begin TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TStringGrid(FObject).Cols[I]); Holder[I] := Item; end; Result := Holder; end else if Propname = 'Rows' then begin Count := TStringGrid(FObject).RowCount; Holder := VarArrayCreate([0, Count-1], varDispatch); for I := 0 to Count-1 do begin TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TStringGrid(FObject).Rows[I]); Holder[I] := Item; end; Result := Holder; end else Result := inherited GetProperty(PropName); end; function TIStringGridDispatch.GetData: String; var row, col, RowCount, ColCount: Integer; DataTemp, Data: String; begin //OutputDebugString( PChar( 'TIStringGridDispatch.GetData : ' + #13#10 ) ); Data := ''; RowCount := TStringGrid(FObject).RowCount; ColCount := TStringGrid(FObject).ColCount; for row := 0 to RowCount - 1 do begin DataTemp := ''; for col := 0 to ColCount - 1 do begin DataTemp := DataTemp + TStringGrid(FObject).Cells[ col, row ]; if col < ColCount - 1 then DataTemp := DataTemp + #9; end; Data := Data + DataTemp + #13; end; //OutputDebugString( PChar( 'TIStringGridDispatch.GetData Returing: ' + Data + #13#10 ) ); Result := Data; end; { TITreeViewDispatch } procedure TITreeViewDispatch.GetPropNames(var v: Variant); begin inherited GetPropNames(v); end; function TITreeViewDispatch.GetProperty(PropName: String): Variant; var Count: Integer; I: Integer; Holder: Variant; Nodes: TTreeNodes; Node, NodeTemp: TTreeNode; NodePath: string; begin //OutputDebugString( PChar( 'TITreeViewDispatch.GetProperty : ' + PropName + #13#10) ); if Propname = 'Items' then begin Nodes := TTreeView(FObject).Items; Count := Nodes.Count; Holder := VarArrayCreate([0, Count-1], varOleStr); for I := 0 to Count - 1 do begin Node := Nodes.Item[ I ]; NodeTemp := Node.Parent; NodePath := Node.Text; while( NodeTemp <> nil ) do begin NodePath := NodeTemp.Text + '->' + NodePath; NodeTemp := NodeTemp.Parent; end; Holder[I] := Copy( NodePath, 0, MaxStringItem); end; Result := Holder; end else Result := inherited GetProperty(PropName); end; { TIControlDispatch } function TIControlDispatch.GetParent: Variant; begin TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TControl(FObject).Parent) end; {TIWinControlDispatch} function TIWinControlDispatch.GetControls(Index: Integer): Variant; begin if (Index >= 0) and (Index < TWinControl(FObject).ControlCount) then TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TWinControl(FObject).Controls[Index]) else ; // OleError(DISP_E_BADINDEX); end; function TIWinControlDispatch.GetHandle: Integer; begin Result := TWinControl(FObject).Handle; end; function TIWinControlDispatch.GetControlCount: Integer; begin Result := TWinControl(FObject).ControlCount; end; function TIWinControlDispatch.ControlAtPos(X, Y: Integer): Variant; var Pt: TPoint; Control: TControl; begin Pt.y := Y; Pt.x := X; Control := TWinControl(FObject).ControlAtPos(Pt, True); if Control <> nil then TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Control) else ; // OleError(DISP_E_BADINDEX); end; { TIApplicationDispatch } constructor TIApplicationDispatch.Create; begin FObject := Application; inherited Create; end; function TIApplicationDispatch.GetDispFromHandle(Handle: Integer): Variant; var Obj: TObject; begin Obj := FindControl(Handle); if (Obj <> nil) then TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Obj) else ; // OleError(DISP_E_PARAMNOTFOUND); end; function TIApplicationDispatch.GetHandle: Integer; begin Result := TApplication(FObject).Handle; end; function TIApplicationDispatch.GetExeName: String; begin Result := TApplication(FObject).ExeName; end; function TIApplicationDispatch.GetMainForm: Variant; begin TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TApplication(FObject).MainForm); end; procedure RegisterAutomationServer; const AutoClassInfo: TAutoClassInfo = ( AutoClass: TIApplicationDispatch; ProgID: 'SQAServer.Application'; ClassID: '{92E4FBC0-1169-11D0-B5AB-00A02484352C}'; Description: 'SQA Test Automation Server'; Instancing: acMultiInstance); begin Automation.RegisterClass(AutoClassInfo); end; function GetPropertyName : string; var propName : string; begin Result := 'SQAApplicationObject'; if ( System.IsLibrary ) then begin propName := Format( 'SQAApplicationObject_%x', [ HInstance ] ); Result := propName; end; end; function GetApplicationHandle: THandle; var appHandle : THandle; begin Result := Application.Handle; if ( Result = 0 ) then begin appHandle := FindWindow( PChar( 'TApplication' ), nil ); Result := appHandle; end; end; procedure BeautifyApplicationWindow; var appD : TIApplicationDispatch; propName : string; aut : TAutoDispatch; V : ^Variant; appHandle : THandle; begin propName := GetPropertyName( ); appHandle := GetApplicationHandle( ); //OutputDebugString( PChar( Format( 'DEEnabler: Application handle :<%x>' + #13#10, [ appHandle ] ) ) ); if ( GetProp( appHandle, PChar(propName) ) = 0 ) then begin New( V ); VarClear( V^ ); appD := TIApplicationDispatch.Create( ); aut := appD.AutoDispatch; TVarData(V^).VType := varDispatch; TVarData(V^).VDispatch := aut; //VarToInterface(V^).AddRef; //OutputDebugString( PChar( Format( 'DEEnabler: SetProp <%s> apphandle <%x> object <%x>' + #13#10, [ PChar(propName), appHandle, THandle( V ) ] ) ) ); SetProp( appHandle, PChar(propName), THandle( V ) ); end; end; procedure RevertApplicationWindowChanges; var th : THandle; V : PVariant; propName : PChar; appHandle : THandle; begin propName := 'SQAApplicationObject'; appHandle := GetApplicationHandle(); th := Windows.GetProp( appHandle, propName ); if ( th <> 0 ) then begin V := PVariant(th); Dispose( V ); //VarToInterface(V^).Release; Windows.RemoveProp( appHandle, propName ); end; end; function TIApplicationDispatch.FindControl1(hWndToFind: HWnd): TWinControl; var lControlAtom: TAtom; lControlAtomString: string; lOwningProcess: Pointer; lUnknownProcess: DWORD; lRM_GetObjectInstance: DWORD; begin Result := nil; if (hWndToFind <> 0) then begin lControlAtomString := Format('ControlOfs%.8X%.8X', [GetWindowLong( hWndToFind, GWL_HINSTANCE), GetCurrentThreadID]); lControlAtom := GlobalAddAtom(PChar(lControlAtomString)); if GlobalFindAtom(PChar(lControlAtomString)) = lControlAtom then begin Result := Pointer(GetProp(hWndToFind, MakeIntAtom(lControlAtom))) end else begin lRM_GetObjectInstance := RegisterWindowMessage(PChar(lControlAtomString)); lOwningProcess := nil; GetWindowThreadProcessID(hWndToFind, lOwningProcess); lUnknownProcess := GetCurrentProcessID(); if DWORD(lOwningProcess) = lUnknownProcess then begin Result := Pointer(SendMessage(hWndToFind, lRM_GetObjectInstance, 0, 0)) end else begin Result := nil; end; end; end; end; begin RegisterAutomationEnabler(TObject, TIObjectDispatch); RegisterAutomationEnabler(TComponent, TIComponentDispatch); RegisterAutomationEnabler(TControl, TIControlDispatch); RegisterAutomationEnabler(TWinControl, TIWinControlDispatch); // SJP: Added 07/01/96. RegisterAutomationEnabler(TCollection, TICollectionDispatch); // SJP: Added 07/08/96. RegisterAutomationEnabler(TDataSet, TIDataSetDispatch); // SJP: Added 07/08/96. RegisterAutomationEnabler(TStrings, TIStringsDispatch); // SJP: Added 08/04/96. RegisterAutomationEnabler(TOleControl, TIOleControlDispatch); // SJP: Added 03/12/97. RegisterAutomationEnabler(TStringGrid, TIStringGridDispatch); // TreeView support RegisterAutomationEnabler(TTreeView, TITreeViewDispatch); //RegisterAutomationServer; BeautifyApplicationWindow( ); end.