unit ComUtils;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
	Classes, Graphics, ComObj, VarUtils, ActiveX, Variants, Windows, RefObjects, ExceptionUtils;

//	Типы и константы, забытые борландом
//	НАЧАЛО
const
	RPC_C_AUTHN_LEVEL_NONE = 1;
	RPC_C_IMP_LEVEL_IMPERSONATE = 3;
	EOAC_NONE = 0;

type
	PCoAuthIdentity = ^TCoAuthIdentity;
	TCoAuthIdentity = record
		User: PWideChar;
		UserLength: ULONG;
		Domain: PWideChar;
		DomainLength: ULONG;
		Password: PWideChar;
		PasswordLength: ULONG;
		Flags: ULONG;
	end;

	PCoAuthInfo = ^TCoAuthInfo;
	TCoAuthInfo = record
		dwAuthnSvc: DWORD;
		dwAuthzSvc: DWORD;
		pwszServerPrincName: PWideChar;
		dwAuthnLevel: DWORD;
		dwImpersonationLevel: DWORD;
		pAuthIdentityData: PCoAuthIdentity;
		dwCapabilities: DWORD;
	end;
//	Типы и константы, забытые борландом
//	КОНЕЦ

type
	TVarMemType = (vmStr, vmOleStr, vmByteArray);
const
	DefVarMemType = vmOleStr;

procedure RegisterAppID(aComServer: TComServerObject; aRegister: Boolean; const anAppID: String);
procedure CreateRegVal(const aKey, aName, aValue: String); overload;
procedure CreateRegVal(const aKey, aName: String; aValue: Integer); overload;
procedure DeleteRegVal(const aKey, aName: String);

function VarToStr(const v: Variant): String;
function StrToVar(const s: String): Variant;
function VarPair(const aName: String; const aValue: Variant): Variant;
function LBound(const anArray: Variant): Integer;
function UBound(const anArray: Variant): Integer;
function VarArrayLength(const anArray: Variant): Integer;
function VarArrayToStr(const anArray: Variant; aDivider: String): String;
function VarToInt(const v: Variant; out aValue: Integer): Boolean;
function VarToString(const v: Variant; out aValue: String): Boolean;
function VarToUnknown(const v: Variant; out aValue: IUnknown): Boolean;
function VarIsObject(const v: Variant): Boolean;

function VarMemAlloc(aType: TVarMemType; aData: Pointer; aSize: Integer): Variant;
function VarMemSize(const v: Variant): Integer;
function VarMemLock(const v: Variant): Pointer;
procedure VarMemUnlock(const v: Variant);
function VarMemToMemStm(const v: Variant): TMemoryStream;
function MemStmToVarMem(aType: TVarMemType; aMemStm: TMemoryStream): Variant;

procedure CopyVarBytesToMemory(const aVarBytes: Variant; var aMem; aSize: Longint);
procedure CopyMemoryToVarBytes(const aMem; aSize: Longint; out aVarBytes: Variant);

function StrToBLOB(const s: string): OleVariant;
function BLOBToStr(const v: OleVariant): string;

procedure StringsToVarArray(aList: TStrings; out aVar: Variant);
procedure VarArrayToStrings(const aVar: Variant; aList: TStrings);

procedure CreateVarVector(aCount, aType: Integer; out aVector: Variant);
procedure CreateVarTable(aRowCount, aFieldCount, aType: Integer; out aTable: Variant);
procedure CreateVarBytes(aSize: Integer; out aBytes: Variant);
function VarIsEquals(const v1, v2: Variant): Boolean;

function VarBytesSize(const aVarBytes: Variant): Integer;

procedure BitmapToVariant(aBitmap: Graphics.TBitmap; out aData: Variant);
procedure VariantToBitmap(const aData: Variant; aBitmap: Graphics.TBitmap);

function VarIndirect(const aValue: Variant): Variant;
function CompareVariants(const A, B: Variant): Integer;

type
	TEvGetCount = function: Integer of object;
	TEvGetItem = function(anIndex: Integer): OleVariant of object;

	TEnumVARIANT = class(TInterfacedObject, IEnumVARIANT)
	private
		FOuter: IUnknown;
	protected
		function Next(celt: LongWord; var rgvar : OleVariant;
			out pceltFetched: LongWord): HResult; stdcall;
		function Skip(celt: LongWord): HResult; stdcall;
		function Reset: HResult; stdcall;
		function Clone(out Enum: IEnumVariant): HResult; stdcall;
	public
		OnGetCount: TEvGetCount;
		OnGetItem: TEvGetItem;
		CurIndex: Integer;
		constructor Create(anOnGetCount: TEvGetCount; anOnGetItem: TEvGetItem; const anOuter: IUnknown = nil);
		destructor Destroy; override;
	end;

	IDestroyNotify = interface
		['{78AB24CE-FBBF-11D3-970E-000021C6D845}']
		procedure DestroyNotify(aSender: TObject);
	end;

	TChildIntf = class(TAutoIntfObject)
	private
		FParent: IUnknown;
	public
		constructor Create(const aTlb: ITypeLib; const aDisp: TIID;
			const aParent: IUnknown);
		procedure DetachParent;
		destructor Destroy; override;
	end;

	IGetImplObject = interface
		['{34866B91-A3E8-11D3-9698-000021C6D845}']
		function GetImplObject(aCallerProcessID: DWORD): TObject;
	end;
	TItemState = (isExisting, isModified, isNew, isDeleted);
	TItemStates = set of TItemState;

	TMasterObjectClass = class of TMasterObject;
	TMasterObject = class(TRefObject)
	private
		FParent: TMasterObject;
	protected
		FIntf: Pointer;
		FExternalRefCount: Integer;
		procedure SetParent(aParent: TMasterObject);
	public
		constructor Create(aParent: TMasterObject);
		procedure ExternalRef(aCount: Integer);
		function FindParent(aClass: TMasterObjectClass): TMasterObject;

		procedure DoWillChange(aChild: TMasterObject; aSender: TObject); virtual;
		procedure DoChangeComplete(aChild: TMasterObject; aSender: TObject); virtual;

		procedure WillChange(aSender: TObject = nil);
		procedure ChangeComplete(aSender: TObject = nil);

		property Parent: TMasterObject read FParent write SetParent;
	end;

	TMasterIntf = class(TAutoIntfObject)
	protected
		FMaster: TMasterObject;
	public
		constructor Create(aMaster: TMasterObject; const aTlb: ITypeLib; const aDisp: TGUID);
		destructor Destroy; override;
	end;

	TMasterAuto = class(TAutoObject)
	protected
		FMaster: TMasterObject;
	public
		constructor Create(aMaster: TMasterObject);
		destructor Destroy; override;
	end;

	TMasterEnum = class(TEnumVariant)
	private
		FMaster: TMasterObject;
	public
		constructor Create(aMaster: TMasterObject;
			anOnGetCount: TEvGetCount; anOnGetItem: TEvGetItem);
		destructor Destroy; override;
	end;

	TDispHelper = class(TInterfacedObject, IDispatch)
	private
		FPropList: array of record Name: String; Value: OleVariant end;

		function GetTypeInfoCount(out aCount: Integer): HResult; stdcall;
		function GetTypeInfo(anIndex, aLocaleID: Integer; out aTypeInfo): HResult; stdcall;
		function GetIDsOfNames(const anIID: TGUID; aNames: Pointer;
			aNameCount, aLocaleID: Integer; aDispIDs: Pointer): HResult; stdcall;
		function Invoke(aDispID: Integer; const anIID: TGUID; aLocaleID: Integer;
			aFlags: Word; var aParams; aVarResult, anExcepInfo, anArgErr: Pointer): HResult; stdcall;
		function IndexOfName(const aName: String): Integer;
	public
		procedure Add(const aName: String; const aValue: OleVariant);
		function GetValue(i: Integer): OleVariant; overload;
		function GetValue(const aName: String): OleVariant; overload;
	end;

	TDataDisp = class(TInterfacedObject, IDispatch)
		FValue: OleVariant;

		function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
		function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
		function GetIDsOfNames(const IID: TGUID; Names: Pointer;NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
		function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
			Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
	end;

	
//	Загрузить и зарегистрировать библиотеку типов, размещенную в файле aName
//	ЗАМЕЧАНИЕ: Параметр aName не должен содержать пути, только имя файла.
//		Файл должен находится там же, где и текущий исполняемый файл или DLL.
//
function LoadTypeLibFromFile(const aName: String): ITypeLib;
procedure RegisterTypeLibrary(const s: String);
function LoadTypeLibFromRes(aResID: Integer; aReg: Boolean = False): ITypeLib;
function TlbExistInRes(aResID: Integer): Boolean;

procedure DispExecuteMethod(const aDisp: IDispatch;
	const aMethodName: WideString); overload;
procedure DispExecuteMethod(const aDisp: IDispatch;
	const aMethodName: WideString; const aParams: array of OleVariant); overload;
procedure DispExecuteMethod(const aDisp: IDispatch;
	aDispID: TDispID); overload;
procedure DispExecuteMethod(const aDisp: IDispatch;
	aDispID: TDispID; const aParams: array of OleVariant); overload;
procedure DispExecuteMethodByRefParams(const aDisp: IDispatch;
	aDispID: TDispID; aParamCount: Integer; aParams: POleVariant); overload;
procedure DispExecuteMethodByRefParams(const aDisp: IDispatch;
	const aSub: WideString; aParamCount: Integer; aParams: POleVariant); overload;
function DispMethodExists(const aDisp: IDispatch; const aMethodName: WideString): Boolean;
function FindMethodDispID(const aDisp: IDispatch; const aMethodName: WideString): TDispID;

procedure DisableComSecurity;

function VarIsEmptyParam(const v: Variant): Boolean;

function GetImplObject(const anIntf: IUnknown): TObject;
procedure CheckGetImplObject(aCallerProcessID: Integer);

function TryVarToInt(v: OleVariant; out i: Integer): Boolean;


implementation

uses
	Registry, SysUtils;

type
	TCoClassRegister = class
		DoRegister: Boolean;
		AppID: String;
		constructor Create(aDoRegister: Boolean; const anAppID: String);
		procedure RegisterFactory(aFactory: TComObjectFactory);
	end;

function GetImplObject(const anIntf: IUnknown): TObject;
var
	aGetImpl: IGetImplObject;
begin
	aGetImpl := anIntf as IGetImplObject;
	Result := aGetImpl.GetImplObject(GetCurrentProcessID);
	if not Assigned(Result) then
		raise Exception.Create('Ошибка получения внутреннего объекта (GetImplObject)');
end;

procedure CheckGetImplObject(aCallerProcessID: Integer);
begin
	if GetCurrentProcessID <> DWORD(aCallerProcessID) then
		raise Exception.Create('Ошибка получения ссылки на объект: вызывающая сторона выполняется в другом процессе.');
end;

constructor TCoClassRegister.Create(aDoRegister: Boolean; const anAppID: String);
begin
	inherited Create;
	DoRegister := aDoRegister;
	AppID := anAppID;
end;

procedure TCoClassRegister.RegisterFactory(aFactory: TComObjectFactory);
var
	aClassID: string;
begin
	aClassID := GUIDToString(aFactory.ClassID);
	if DoRegister then begin
		CreateRegKey('CLSID\' + aClassID, 'AppID', AppID);
		CreateRegKey('AppID\' + AppID, '', aFactory.Description);
	end
	else 
		DeleteRegKey('AppID\' + AppID);
end;

procedure RegisterAppID(aComServer: TComServerObject; aRegister: Boolean; const anAppID: String);
var
	aCoClassRegister: TCoClassRegister;
begin
	aCoClassRegister := TCoClassRegister.Create(aRegister, anAppID);
	try
		ComClassManager.ForEachFactory(aComServer, aCoClassRegister.RegisterFactory);
	finally
		aCoClassRegister.Free;
	end;
end;

procedure CreateRegVal(const aKey, aName, aValue: String); overload;
var
	aRegistry: TRegistry;
begin
	aRegistry := TRegistry.Create;
	try
		aRegistry.RootKey := HKEY_CLASSES_ROOT;
		if aRegistry.OpenKey(aKey, True) then
			aRegistry.WriteString(aName, aValue);
	finally
		aRegistry.Free
	end
end;

procedure CreateRegVal(const aKey, aName: String; aValue: Integer); overload;
var
	aRegistry: TRegistry;
begin
	aRegistry := TRegistry.Create;
	try
		aRegistry.RootKey := HKEY_CLASSES_ROOT;
		if aRegistry.OpenKey(aKey, True) then
			aRegistry.WriteInteger(aName, aValue);
	finally
		aRegistry.Free
	end
end;

procedure DeleteRegVal(const aKey, aName: String);
var
	aRegistry: TRegistry;
begin
	aRegistry := TRegistry.Create;
	try
		aRegistry.RootKey := HKEY_CLASSES_ROOT;
		if aRegistry.OpenKey(aKey, False) then
			aRegistry.DeleteValue(aName);
	finally
		aRegistry.Free
	end
end;

function VarPair(const aName: String; const aValue: Variant): Variant;
begin
	Result := VarArrayOf([aName, aValue]);
end;

function LBound(const anArray: Variant): Integer;
begin
	Result := VarArrayLowBound(anArray, 1);
end;

function UBound(const anArray: Variant): Integer;
begin
	Result := VarArrayHighBound(anArray, 1);
end;

function VarToStr(const v: Variant): String;
begin
	if VarIsEmpty(v) or VarIsNull(v) then
		Result := ''
	else
		Result := v;
end;

function StrToVar(const s: String): Variant;
begin
	if s = '' then
		Result := Null
	else
		Result := s;
end;

function VarArrayLength(const anArray: Variant): Integer;
begin
	if VarIsArray(anArray, true) then
		Result := UBound(anArray) - LBound(anArray) + 1
	else
		Result := 0;
end;

function VarArrayToStr(const anArray: Variant; aDivider: String): String;
var
	i: Integer;
begin
	if not VarIsArray(anArray, true) then
		Result := anArray
	else if VarArrayLength(anArray) = 0 then
		Result := ''
	else begin
		Result := anArray[LBound(anArray)];
		for i := LBound(anArray) + 1 to UBound(anArray) do
			Result := Result + aDivider + anArray[i];
	end;
end;

function VarToInt(const v: Variant; out aValue: Integer): Boolean;
var
	aDst: OleVariant;
begin
	Result := VariantCopyInd(aDst, v) = S_OK;
	if Result then begin
		Result := VariantChangeType(aDst, aDst, 0, VT_I4) = S_OK;
		if Result then
			aValue := TVarData(aDst).VInteger;
	end;
end;

function VarToString(const v: Variant; out aValue: String): Boolean;
var
	aDst: OleVariant;
begin
	Result := VariantCopyInd(aDst, v) = S_OK;
	if Result then begin
		Result := VariantChangeType(aDst, aDst, 0, VT_BSTR) = S_OK;
		if Result then
			aValue := aDst;
	end
end;

function VarToUnknown(const v: Variant; out aValue: IUnknown): Boolean;
var
	aDst: OleVariant;
begin
	Result := VariantCopyInd(aDst, v) = S_OK;
	if Result then begin
		Result := VariantChangeType(aDst, aDst, 0, VT_UNKNOWN) = S_OK;
		if Result then
			aValue := aDst;
	end;
end;

function VarIsObject(const v: Variant): Boolean;
begin
	Result := VarIsType(v, [varDispatch, varUnknown]);
end;

function VarMemAlloc(aType: TVarMemType; aData: Pointer; aSize: Integer): Variant;
var
	aPtr: Pointer;
begin
	Result := Unassigned;
	if aSize > 0 then
		if aType = vmStr then 
			with TVarData(Result) do begin
				VType := varString;
				System.SetString(String(VString), PChar(aData), aSize);
			end
		else if aType = vmByteArray then begin
			Result := VarArrayCreate([0, aSize - 1], varByte);
			if Assigned(aData) then begin
				aPtr := VarArrayLock(Result);
				try
					Move(aData^, aPtr^, aSize)
				finally
					VarArrayUnlock(Result)
				end
			end
		end
		else
			with TVarData(Result) do begin
				VType := varOleStr;
				VOleStr := SysAllocStringByteLen(nil, aSize);
				if Assigned(aData) then
					Move(aData^, VOleStr^, aSize);
			end
end;

function VarMemSize(const v: Variant): Integer;
begin
	if VarType(v) = varString then
		Result := Length(String(TVarData(v).VString))
	else if VarType(v) = varOleStr then
		Result := SysStringByteLen(TVarData(v).VOleStr)
	else if VarIsArray(v, true) then
		Result := VarArrayHighBound(v, 1) - VarArrayLowBound(v, 1) + 1
	else
		Result := 0;
end;

function VarMemLock(const v: Variant): Pointer;
begin
	if VarType(v) = varString then
		Result := TVarData(v).VString
	else if VarType(v) = varOleStr then
		Result := Pointer(TVarData(v).VOleStr)
	else if VarIsArray(v, true) then
		Result := VarArrayLock(v)
	else
		Result := nil;
end;

procedure VarMemUnlock(const v: Variant);
begin
	if VarIsArray(v, true) then
		VarArrayUnlock(v)
end;

function VarMemToMemStm(const v: Variant): TMemoryStream;
var
	p: Pointer;
begin
	if VarMemSize(v) = 0 then
		Result := nil
	else begin
		p := VarMemLock(v);
		try
			Result := TMemoryStream.Create;
			try
				Result.Write(p^, VarMemSize(v));
				Result.Position := 0;
			except
				Result.Free;
				raise;
			end;
		finally
			VarMemUnlock(v)
		end
	end
end;

function MemStmToVarMem(aType: TVarMemType; aMemStm: TMemoryStream): Variant;
begin
	if Assigned(aMemStm) and (aMemStm.Size > 0) then
		Result := VarMemAlloc(aType, aMemStm.Memory, aMemStm.Size)
	else
		VarClear(Result)
end;

procedure CreateVarVector(aCount, aType: Integer; out aVector: Variant);
begin
	aVector := VarArrayCreate([0, aCount - 1], aType);
end;

procedure CreateVarTable(aRowCount, aFieldCount, aType: Integer; out aTable: Variant);
begin
	aTable := VarArrayCreate([0, aRowCount - 1, 0, aFieldCount - 1], aType);
end;

procedure CreateVarBytes(aSize: Integer; out aBytes: Variant);
begin
	aBytes := VarMemAlloc(DefVarMemType, nil, aSize);
end;

function IMin(i1, i2: Integer): Integer;
begin
	if i1 < i2 then
		Result := i1
	else
		Result := i2;
end;

procedure CopyVarBytesToMemory(const aVarBytes: Variant; var aMem; aSize: Longint);
var
	aVarSize: Longint;
	aPtr: Pointer;
begin
	aVarSize := VarMemSize(aVarBytes);
	if aSize <> 0 then begin
		aPtr := VarMemLock(aVarBytes);
		try
			Move(aPtr^, aMem, IMin(aSize, aVarSize))
		finally
			VarMemUnlock(aVarBytes);
		end;
	end;
end;

procedure CopyMemoryToVarBytes(const aMem; aSize: Longint; out aVarBytes: Variant);
var
	aPtr: Pointer;
begin
	aVarBytes := VarMemAlloc(DefVarMemType, nil, aSize);
	aPtr := VarMemLock(aVarBytes);
	try
		Move(aMem, aPtr^, aSize)
	finally
		VarMemUnlock(aVarBytes);
	end;
end;

procedure StringsToVarArray(aList: TStrings; out aVar: Variant);
var
	i: Integer;
begin
	CreateVarVector(aList.Count, varOleStr, aVar);
	for i := 0 to aList.Count - 1 do
		aVar[i] := WideString(aList[i]);
end;

procedure VarArrayToStrings(const aVar: Variant; aList: TStrings);
var
	i, aLow, aHigh: Integer;
begin
	with aList do begin
		BeginUpdate;
		try
			Clear;
			if VarIsArray(aVar, true) then begin
				aLow := VarArrayLowBound(aVar, 1);
				aHigh := VarArrayHighBound(aVar, 1);
				Capacity := aHigh - aLow + 1;
				for i := aLow to aHigh do
					Add(aVar[i]);
			end;
		finally
			EndUpdate
		end
	end;
end;

function VarBytesSize(const aVarBytes: Variant): Integer;
begin
	Result := VarMemSize(aVarBytes);
end;

function VarIsEquals(const v1, v2: Variant): Boolean;
var
	s1, s2: Integer;
	p1, p2: Pointer;
	vt1, vt2: Word;
	ws1, ws2: WideString;
begin
	vt1 := VarType(v1);
	vt2 := VarType(v2);
	if vt1 = varNull then
		Result := vt2 = varNull
	else if vt1 = varEmpty then
		Result := vt2 = varEmpty
	else if (vt1 = (varArray + varByte)) and (vt2 = (varArray + varByte)) then begin
		s1 := VarArrayHighBound(v1, 1) + 1;
		s2 := VarArrayHighBound(v2, 1) + 1;
		if s1 <> s2 then
			Result := False
		else begin
			p1 := VarArrayLock(v1);
			try
				p2 := VarArrayLock(v2);
				try
					Result := CompareMem(p1, p2, s1);
				finally
					VarArrayUnlock(v2);
				end
			finally
				VarArrayUnlock(v1);
			end;
		end
	end
	else if vt2 in [varNull, varEmpty] then
		Result := False
	else if (vt1 = varString) and (vt2 = varOleStr) or
		(vt2 = varString) and (vt1 = varOleStr)
	then begin
		ws1 := v1;
		ws2 := v2;
		Result := ws1 = ws2;
	end
	else begin
		if (VarIsArray(v1) and not VarIsArray(v2)) or (VarIsArray(v2) and not VarIsArray(v1)) then begin
			Result := False;
			Exit;
		end;

		try
			Result := v1 = v2;
		except
			Result := False
		end;
	end;
end;

procedure BitmapToVariant(aBitmap: Graphics.TBitmap; out aData: Variant);
var
	anImageStm: TMemoryStream;
	anImagePtr: Pointer;
begin
	anImageStm := TMemoryStream.Create;
	try
		aBitmap.SaveToStream(anImageStm);
		aData := VarArrayCreate([0, anImageStm.Size - 1], varByte);
		anImagePtr := VarArrayLock(aData);
		try
			Move(anImageStm.Memory^, anImagePtr^, anImageStm.Size);
		finally
			VarArrayUnlock(aData)
		end;
	finally
		anImageStm.Free
	end
end;

procedure VariantToBitmap(const aData: Variant; aBitmap: Graphics.TBitmap);
var
	aStm: TMemoryStream;
	aPtr: Pointer;
begin
	aStm := TMemoryStream.Create;
	try
		aPtr := VarArrayLock(aData);
		try
			aStm.Write(aPtr^, VarArrayLength(aData));
			aStm.Position := 0;
			aBitmap.LoadFromStream(aStm);
		finally
			VarArrayUnlock(aData)
		end
	finally
		aStm.Free;
	end;
end;

{ TEnumVARIANT }

constructor TEnumVARIANT.Create(anOnGetCount: TEvGetCount; anOnGetItem: TEvGetItem; const anOuter: IUnknown = nil);
begin
	inherited Create;
	FOuter := anOuter;
	OnGetCount := anOnGetCount;
	OnGetItem := anOnGetItem;
end;

destructor TEnumVARIANT.Destroy;
begin
	FOuter := nil;
	inherited;
end;

function TEnumVARIANT.Clone(out Enum: IEnumVariant): HResult;
begin
	Enum := TEnumVariant.Create(OnGetCount, OnGetItem, FOuter);
	Result := S_OK;
end;

function TEnumVARIANT.Next(celt: LongWord; var rgvar : OleVariant;
	out pceltFetched: LongWord): HResult;
var
	aVar: ^OleVariant;
	i1: Integer;
	i2: LongWord;
begin
	if Assigned(@pceltFetched) then
		pceltFetched := 0;

	aVar := @rgvar;
	Initialize(aVar^, celt);

	i1 := CurIndex;
	i2 := 0;
	while (i1 < OnGetCount) and (i2 < celt) do begin
		aVar^ := OnGetItem(i1);
		Inc(aVar);
		Inc(i1);
		Inc(i2);
	end;
	if Assigned(@pceltFetched) then
		pceltFetched := i2;
	CurIndex := i1;
	if i2 < celt then
		Result := S_FALSE
	else
		Result := S_OK
end;

function TEnumVARIANT.Reset: HResult;
begin
	CurIndex := 0;
	Result := S_OK;
end;

function TEnumVARIANT.Skip(celt: LongWord): HResult;
begin
	Inc(CurIndex, celt);
	if CurIndex > OnGetCount then begin
		CurIndex := OnGetCount;
		Result := S_FALSE;
	end
	else
		Result := S_OK
end;

constructor TMasterObject.Create(aParent: TMasterObject);
begin
	inherited Create;
	FParent := aParent;
end;

procedure TMasterObject.ExternalRef(aCount: Integer);
var
	i: Integer;
begin
	Inc(FExternalRefCount, aCount);
	if aCount > 0 then begin
		for i := 1 to aCount do
			AddRef;
		if Assigned(FParent) then
			FParent.ExternalRef(aCount);
	end
	else begin
		if Assigned(FParent) then
			FParent.ExternalRef(aCount);
		for i := 1 to -aCount do
			Release;
	end;
end;

procedure TMasterObject.SetParent(aParent: TMasterObject);
begin
	if aParent <> FParent then begin
		if Assigned(FParent) and (FExternalRefCount > 0) then
			FParent.ExternalRef(-FExternalRefCount);
		FParent := aParent;
		if Assigned(aParent) and (FExternalRefCount > 0) then
			aParent.ExternalRef(-FExternalRefCount);
	end;
end;

function TMasterObject.FindParent(aClass: TMasterObjectClass): TMasterObject;
begin
	Result := Self;
	while Assigned(Result) do
		if Result.ClassType = aClass then
			Exit
		else
			Result := Result.FParent;
end;

procedure TMasterObject.DoWillChange(aChild: TMasterObject; aSender: TObject);
begin
	if Assigned(FParent) then
		FParent.DoWillChange(Self, aSender);
end;

procedure TMasterObject.DoChangeComplete(aChild: TMasterObject; aSender: TObject);
begin
	if Assigned(FParent) then
		FParent.DoChangeComplete(Self, aSender)
end;

procedure TMasterObject.WillChange(aSender: TObject);
begin
	if not Assigned(aSender) then
		aSender := Self;
	DoWillChange(Self, aSender);
end;

procedure TMasterObject.ChangeComplete(aSender: TObject);
begin
	if not Assigned(aSender) then
		aSender := Self;
	DoChangeComplete(Self, aSender);
end;

////////////////////////////////////////////////////////////////////////////////
//	TMasterIntf
//
constructor TMasterIntf.Create(aMaster: TMasterObject; const aTlb: ITypeLib; const aDisp: TGUID);
begin
	inherited Create(aTlb, aDisp);
	FMaster := aMaster;
	FMaster.ExternalRef(1);
	FMaster.FIntf := Self;
end;

destructor TMasterIntf.Destroy;
begin
	FMaster.FIntf := nil;
	FMaster.ExternalRef(-1);
	inherited;
end;

////////////////////////////////////////////////////////////////////////////////
//	TMasterAuto
//
constructor TMasterAuto.Create(aMaster: TMasterObject);
begin
	inherited Create;
	FMaster := aMaster;
	FMaster.ExternalRef(1);
	FMaster.FIntf := Self;
end;

destructor TMasterAuto.Destroy;
begin
	FMaster.FIntf := nil;
	FMaster.ExternalRef(-1);
	inherited;
end;

////////////////////////////////////////////////////////////////////////////////
//	TMasterEnum
//
constructor TMasterEnum.Create(aMaster: TMasterObject;
	anOnGetCount: TEvGetCount; anOnGetItem: TEvGetItem);
begin
	inherited Create(anOnGetCount, anOnGetItem);
	FMaster := aMaster;
	aMaster.ExternalRef(1);
end;

destructor TMasterEnum.Destroy;
begin
	FMaster.ExternalRef(-1);
	inherited;
end;

function LoadTypeLibFromFile(const aName: String): ITypeLib;
var
	aBuf: array [0..MAX_PATH] of Char;
	s: WideString;
begin
	Win32Check(GetModuleFileName(HInstance, aBuf, sizeof(aBuf)) <> 0);
	s := ExtractFilePath(aBuf) + aName;
	OleCheck(LoadTypeLib(PWideChar(s), Result));
	OleCheck(RegisterTypeLib(Result, PWideChar(s), nil));
end;

function LoadTypeLibFromRes(aResID: Integer; aReg: Boolean): ITypeLib;
const
	RegKinds: array[Boolean] of TREGKIND = (REGKIND_NONE, REGKIND_REGISTER);
var
	aBuf: array [0..MAX_PATH] of Char;
	s: WideString;
begin
	Win32Check(GetModuleFileName(HInstance, aBuf, sizeof(aBuf)) <> 0);
	s := aBuf;
	s := s + '\' + IntToStr(aResID);
	OleCheck(LoadTypeLibEx(PWideChar(s), RegKinds[aReg] ,Result));
end;

function TlbExistInRes(aResID: Integer): Boolean;
begin
	Result := FindResource(HInstance, PChar('#' + IntToStr(aResID)), 'TYPELIB') <> 0;
end;

procedure RegisterTypeLibrary(const s: String);
var
	aName: WideString;
	aTypeLib: ITypeLib;
begin
	aName := s;
	OleCheck(LoadTypeLib(PWideChar(aName), aTypeLib));
	OleCheck(RegisterTypeLib(aTypeLib, PWideChar(aName), nil));
end;

//	Disp Execute with DispID
procedure DispExecuteMethod(const aDisp: IDispatch;
	aDispID: TDispID);
var
	DispParamsNoArgs: TDISPPARAMS;
	hr: HResult;
	excep: TEXCEPINFO;
begin
	FillChar(DispParamsNoArgs, SizeOf(DispParamsNoArgs), 0);
	hr := aDisp.Invoke(aDispID, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD,
		DispParamsNoArgs, nil, @excep, nil);
	if hr <> S_OK then
		DispatchInvokeError(hr, excep);
end;

procedure DispExecuteMethod(const aDisp: IDispatch;
	aDispID: TDispID; const aParams: array of OleVariant);
var
	aDispParams: TDISPPARAMS;
	anArgs: array of OleVariant;
	i, anArgErr: Integer;
	hr: HResult;
	excep: TEXCEPINFO;
begin
	aDispParams.rgdispidNamedArgs := nil;
	aDispParams.cNamedArgs := 0;
	SetLength(anArgs, Length(aParams));
	for i := 0 to Length(anArgs) - 1 do
		anArgs[i] := aParams[Length(aParams) - 1 - i];
	aDispParams.cArgs := Length(aParams);
	aDispParams.rgvarg := @anArgs[0];
	hr := aDisp.Invoke(aDispID, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD,
		aDispParams, nil, @excep, @anArgErr);
	if hr <> S_OK then
		DispatchInvokeError(hr, excep);
end;

procedure DispExecuteMethodByRefParams(const aDisp: IDispatch;
	aDispID: TDispID; aParamCount: Integer; aParams: POleVariant);
var
	aDispParams: TDISPPARAMS;
	anArgErr: Integer;
	hr: HResult;
	excep: TEXCEPINFO;
begin
	aDispParams.rgdispidNamedArgs := nil;
	aDispParams.cNamedArgs := 0;
	aDispParams.cArgs := aParamCount;
	aDispParams.rgvarg := PVariantArgList(aParams);
	hr := aDisp.Invoke(aDispID, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_METHOD,
		aDispParams, nil, @excep, @anArgErr);
	if hr <> S_OK then
		DispatchInvokeError(hr, excep);
end;

procedure DispExecuteMethodByRefParams(const aDisp: IDispatch;
	const aSub: WideString; aParamCount: Integer; aParams: POleVariant);
var
	aWideName: PWideChar;
	aDispID: TDISPID;
	hr: HResult;
begin
	if aSub = '' then
		aDispID := 0
	else begin
		aWideName := PWideChar(aSub);
		hr := aDisp.GetIDsOfNames(GUID_NULL, @aWideName, 1, LOCALE_SYSTEM_DEFAULT,
			@aDispID);
		if hr = DISP_E_UNKNOWNNAME then
			raise Exception.CreateFmt(
				'Ошибка выполнения метода: Объект не содержит метод "%s"',
				[aSub]);
	end;
	DispExecuteMethodByRefParams(aDisp, aDispID, aParamCount, aParams);
end;

//	Disp Execute With Name
procedure DispExecuteMethod(const aDisp: IDispatch; const aMethodName: WideString);
var
	aWideName: PWideChar;
	aDispID: TDISPID;
	hr: HResult;
begin
	if aMethodName = '' then
		aDispID := 0
	else begin
		aWideName := PWideChar(aMethodName);
		hr := aDisp.GetIDsOfNames(GUID_NULL, @aWideName, 1, LOCALE_SYSTEM_DEFAULT,
			@aDispID);
		if hr = DISP_E_UNKNOWNNAME then
			raise Exception.CreateFmt(
				'Ошибка выполнения метода: Объект не содержит метод "%s"',
				[aMethodName]);
	end;
	DispExecuteMethod(aDisp, aDispID);
end;

procedure DispExecuteMethod(const aDisp: IDispatch; const aMethodName: WideString;
	const aParams: array of OleVariant);
var
	aWideName: PWideChar;
	aDispID: TDISPID;
	hr: HResult;
begin
	if aMethodName = '' then
		aDispID := 0
	else begin
		aWideName := PWideChar(aMethodName);
		hr := aDisp.GetIDsOfNames(GUID_NULL, @aWideName, 1, LOCALE_SYSTEM_DEFAULT,
			@aDispID);
		if hr = DISP_E_UNKNOWNNAME then
			raise Exception.CreateFmt(
				'Ошибка выполнения метода: Объект не содержит метод "%s"',
				[aMethodName]);
	end;
	DispExecuteMethod(aDisp, aDispID, aParams);
end;

function DispMethodExists(const aDisp: IDispatch; const aMethodName: WideString): Boolean;
var
	aWideName: PWideChar;
	aDispID: TDISPID;
begin
	aWideName := PWideChar(aMethodName);
	Result := aDisp.GetIDsOfNames(GUID_NULL, @aWideName, 1, LOCALE_SYSTEM_DEFAULT,
		@aDispID) = S_OK;
end;

function FindMethodDispID(const aDisp: IDispatch; const aMethodName: WideString): TDispID;
var
	wn: PWideChar;
begin
	wn := PWideChar(aMethodName);
	if aDisp.GetIDsOfNames(GUID_NULL, @wn, 1, LOCALE_SYSTEM_DEFAULT, @Result) <> S_OK
	then
		Result := DISPID_UNKNOWN;
end;

type
	TCoInitializeSecurity = function(pSecDesc: PSecurityDescriptor; cAuthSvc: Longint;
		asAuthSvc: PSOleAuthenticationService; pReserved1: Pointer;
		dwAuthnLevel, dImpLevel: Longint; pReserved2: Pointer; dwCapabilities: Longint;
		pReserved3: Pointer): HResult; stdcall;

procedure DisableComSecurity;
begin
	OleCheck(CoInitializeSecurity(nil, -1, nil, nil, RPC_C_AUTHN_LEVEL_NONE,
		RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE, nil));
end;

////////////////////////////////////////////////////////////////////////////////
//	TChildIntf
//
constructor TChildIntf.Create(const aTlb: ITypeLib; const aDisp: TIID;
	const aParent: IUnknown);
begin
	inherited Create(aTlb, aDisp);
	FParent := aParent;
end;

destructor TChildIntf.Destroy;
begin
	DetachParent;
	inherited;
end;

function VarIsEmptyParam(const v: Variant): Boolean;
begin
	with TVarData(v) do
		Result := (VType = varError) and (HRESULT(VError) = DISP_E_PARAMNOTFOUND)
end;

procedure TChildIntf.DetachParent;
var
	aDestroyNotify: IDestroyNotify;
begin
	if Assigned(FParent) then begin
		if FParent.QueryInterface(IDestroyNotify, aDestroyNotify) = S_OK then
			if Assigned(aDestroyNotify) then
				aDestroyNotify.DestroyNotify(Self);
		FParent := nil;
	end;
end;

{ TDispHelper }

procedure TDispHelper.Add(const aName: String; const aValue: OleVariant);
begin
	SetLength(FPropList, Length(FPropList) + 1);
	with FPropList[Length(FPropList) - 1] do begin
		Name := aName;
		Value := aValue;
	end;
end;

function TDispHelper.GetValue(i: Integer): OleVariant;
begin
	Result := FPropList[i].Value;
end;

function TDispHelper.IndexOfName(const aName: String): Integer;
begin
	for Result := 0 to Length(FPropList) - 1 do
		with FPropList[Result] do
			if Name = aName then
				Exit;
	Result := -1;
end;

function TDispHelper.GetIDsOfNames(const anIID: TGUID; aNames: Pointer;
	aNameCount, aLocaleID: Integer; aDispIDs: Pointer): HResult;
var
	aName: PPWideChar;
	aDispID: ^TDISPID;
	i, j: Integer;
begin
	aName := aNames;
	aDispID := aDispIDs;
	Result := S_OK;
	for i := 0 to aNameCount - 1 do begin
		j := IndexOfName(aName^);
		if j = -1 then begin
			aDispID^ := DISPID_UNKNOWN;
			Result := DISP_E_UNKNOWNNAME;
		end
		else
			aDispID^ := j;
		Inc(aName);
		Inc(aDispID);
	end;
end;

function TDispHelper.Invoke(aDispID: Integer; const anIID: TGUID;
	aLocaleID: Integer; aFlags: Word; var aParams; aVarResult, anExcepInfo,
	anArgErr: Pointer): HResult;
begin
	{TODO:TDispHelper.Invoke}
	if (aDispID >= 0) and (aDispID < Length(FPropList)) then begin
		if (DISPATCH_PROPERTYGET and aFlags) <> 0 then begin
		end
		else if ((DISPATCH_PROPERTYPUT or DISPATCH_PROPERTYPUTREF) and aFlags) <> 0 then begin
		end;
		Result := DISP_E_MEMBERNOTFOUND
	end
	else
		Result := DISP_E_MEMBERNOTFOUND
end;

function TDispHelper.GetTypeInfo(anIndex, aLocaleID: Integer;
	out aTypeInfo): HResult;
begin
	Result := E_NOTIMPL
end;

function TDispHelper.GetTypeInfoCount(out aCount: Integer): HResult;
begin
	Result := E_NOTIMPL
end;

function TDispHelper.GetValue(const aName: String): OleVariant;
var
	i: Integer;
begin
	for i := 0 to Length(FPropList) - 1 do
		with FPropList[i] do
			if Name = aName then begin
				Result := Value;
				Exit
			end;
	raise
		Exception.Create('TDispHelper.GetValue failed: property "' + aName + '" not found');
end;

function StrToBLOB(const s: string): OleVariant;
var
	p: Pointer;
begin
	Result := VarArrayCreate([0, Length(s) - 1], varByte);
	if Length(s) > 0 then begin
		p := VarArrayLock(Result);
		try
			Move(s[1], p^, Length(s));
		finally
			VarArrayUnlock(Result)
		end
	end;
end;

function BLOBToStr(const v: OleVariant): string;
var
	p: Pointer;
	aSize: Integer;
begin
	if VarIsNull(v) then
		Result := ''
	else begin

		aSize := VarArrayHighBound(v, 1) + 1;
		if aSize = 0 then
			Result := ''
		else begin
			p := VarArrayLock(v);
			try
				System.SetString(Result, PChar(p), aSize);
			finally
				VarArrayUnlock(v)
			end
		end
	end;
end;

function TryVarToInt(v: OleVariant; out i: Integer): Boolean;
begin
	Result := VariantChangeType(v, v, 0, varInteger) = S_OK;
	if Result then
		i := v;
end;

{ TDataDisp }

function TDataDisp.GetIDsOfNames(const IID: TGUID; Names: Pointer;
	NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
	Result := E_NOTIMPL;
end;

function TDataDisp.GetTypeInfo(Index, LocaleID: Integer;
	out TypeInfo): HResult;
begin
	Result := E_NOTIMPL;
end;

function TDataDisp.GetTypeInfoCount(out Count: Integer): HResult;
begin
	Result := E_NOTIMPL;
end;

function TDataDisp.Invoke(DispID: Integer; const IID: TGUID;
	LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
	ArgErr: Pointer): HResult;
var
	aDispParams: PDispParams;
begin
	Result := S_OK;
	if DispID = 0 then begin

		if (Flags and DISPATCH_PROPERTYPUT) <> 0 then begin
			aDispParams := @Params;

			if aDispParams.cArgs <> 1 then begin
				Result := DISP_E_BADPARAMCOUNT;
				Exit;
			end;
			FValue := OleVariant(aDispParams.rgvarg[0]);
		end
		else if (Flags and DISPATCH_PROPERTYGET) <> 0 then begin
			if Assigned(VarResult) then
				OleVariant(VarResult^) := FValue
		end
		else
			Result := DISP_E_BADVARTYPE
	end
	else
		Result := DISP_E_MEMBERNOTFOUND
end;

function VarIndirect(const aValue: Variant): Variant;
var
	p: PVarData;
	aDisp: IDispatch;
	aTemp: Variant;
	DispParamsNoArgs: TDISPPARAMS;
	hr: HResult;
	excep: TEXCEPINFO;
begin
	p := FindVarData(aValue);
	while p.VType in [varUnknown, varDispatch] do begin
		if p.VType = varDispatch then
			aDisp := IDispatch(p.VDispatch)
		else if IUnknown(p.VUnknown).QueryInterface(IDispatch, aDisp) <> S_OK then
			throw('Некорректный объект.');

		FillChar(DispParamsNoArgs, SizeOf(DispParamsNoArgs), 0);
		hr := aDisp.Invoke(DISPID_VALUE, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET,
			DispParamsNoArgs, @aTemp, @excep, nil);
		if hr <> S_OK then
			DispatchInvokeError(hr, excep);
		p := FindVarData(aTemp);
	end;
 	Result := Variant(p^);
end;

function CompareVariants(const A, B: Variant): Integer;
var
	LA, LB: TVarData;
const
	LessOrEqual: array [Boolean] of Integer = (-1, 0); 	
	MoreOrEqual: array [Boolean] of Integer = (1, 0); 	
begin
	LA := FindVarData(A)^;
	LB := FindVarData(B)^;
	if LA.VType = varEmpty then
		Result := LessOrEqual[LB.VType = varEmpty]
  else if LA.VType = varNull then
    Result := LessOrEqual[LB.VType = varNull]
	else if LB.VType = varEmpty then
		Result := MoreOrEqual[LA.VType = varEmpty]
	else if LB.VType = varNull then
		Result := MoreOrEqual[LA.VType = varNull]
	else
		Result := VarCmp(LA, LB, 0, 0) - 1;
end;

end.

