iSharkFly-Open
/
VistA-cprs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-cprs/CPRS-Lib/sqasrvr.pas

1703 lines
68 KiB
Plaintext
Raw Permalink Normal View History

Upgrade to version 27
2010-07-07 16:31:10 -04:00
{*************************************************************************
*
* 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.