Есть две программы, каждая реализует один и тот же активх объект, который создается из 1С.
одна на дельфи:| Код |
uses SysUtils, Windows, ActiveX;
type
tclass = class(TObject,IUnknown,IClassFactory,IDispatch)
private
cntref: integer;
public
constructor Create;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
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;
constructor tclass.Create;
begin
cntref := 0;
end;
function tclass._AddRef: Integer;
begin
writeln('AddRef ',cntref);
inc(cntref);
result := cntref;
end;
function tclass._Release: Integer;
begin
writeln('Release', cntref);
dec(cntref);
result := cntref;
if cntref = 0 Then self.Free;
end;
function tclass.QueryInterface(const IID: TGUID; out Obj): HResult;
var s: string;
begin
writeln('QueryInterface');
writeln(GUIDtoString(iid));
result := 0;
s := GuidToString(iid);
if s = '{00000000-0000-0000-C000-000000000046}' then
IInterface(obj) := IUnknown(self)
else
if s = '{00000001-0000-0000-C000-000000000046}' then
IInterface(obj) := IClassFactory(self)
else
if s = '{00020400-0000-0000-C000-000000000046}' then
IInterface(obj) := IDispatch(self)
else begin
writeln('nointerface');
result := E_NOINTERFACE;
end;
end;
//*************************************************************************
function tclass.CreateInstance(const unkOuter: IInterface; const iid: TIID; out obj): HResult;
begin
writeln('CreateInstance');
result := QueryInterface(iid, obj);
end;
function tclass.LockServer(fLock: BOOL): HResult;
begin
writeln('LockServer');
result := -1;
end;
//*************************************************************************
function tclass.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
LocaleID: Integer; DispIDs: Pointer): HResult;
begin
writeln('GetIDsOfNames');
result := -1;
end;
function tclass.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
writeln('GetTypeInfo');
result := -1;
end;
function tclass.GetTypeInfoCount(out Count: Integer): HResult;
begin
writeln('GetTypeInfo');
result := -1;
end;
function tclass.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
writeln('Invoke');
result := -1;
end;
var cl: TClass;
resreg: integer;
h: hresult;
msg: tagMSG;
hw: HWND;
iid: TGuid;
begin
CoInitializeEx(nil, 0);
cl := TClass.Create;
iid := StringToGuid('{044F0B62-51BE-4225-865B-8AFD554107CC}');
//h := CoRegisterClassObject( iid, cl, CLSCTX_LOCAL_SERVER, REGCLS_MULTI_SEPARATE, resreg);
h := CoRegisterClassObject( iid, IUnknown(cl), 4, 2, resreg);
FillChar(msg, sizeof(msg), 0);
hw := 0;
while GetMessage(msg, hw, 0, 0) do Begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
end.
|
(я ее как то даже здесь уже постил), другая... она сложно перевариваема, и ее приводить неимеет смысла, но код примерно такой же.
Так вот. Дельфевый код не создает объект, а на другой языке создается. Вот их логи:| Код |
// это не дельфевая
(`AddRef,0)
(`AddRef,1)
`QueryInterface
"{00000001-0000-0000-C000-000000000046}"
(`AddRef,2)
(`Release,3)
`CreateInstance
`QueryInterface
"{00000000-0000-0000-C000-000000000046}"
(`AddRef,2)
(`AddRef,3)
`QueryInterface
"{00000003-0000-0000-C000-000000000046}"
"nointerface"
`QueryInterface
"{0000001B-0000-0000-C000-000000000046}"
"nointerface"
`QueryInterface
"{00000000-0000-0000-C000-000000000046}"
(`AddRef,4)
(`AddRef,5)
`QueryInterface
"{00000018-0000-0000-C000-000000000046}" // здесь начинаются различия
"nointerface"
`QueryInterface
"{00000019-0000-0000-C000-000000000046}"
"nointerface"
`QueryInterface
"{4C1E39E1-E3E3-4296-AA86-EC938D896E92}"
"nointerface"
(`Release,6)
(`Release,5)
(`Release,4)
(`Release,3)
`QueryInterface
"{00000126-0000-0000-C000-000000000046}"
"nointerface"
`QueryInterface
"{00020400-0000-0000-C000-000000000046}"
(`AddRef,2)
(`AddRef,3)
|
| Код |
AddRef 0
AddRef 1
QueryInterface
{00000001-0000-0000-C000-000000000046}
AddRef 2
Release3
CreateInstance
QueryInterface
{00000000-0000-0000-C000-000000000046}
AddRef 2
AddRef 3
QueryInterface
{00000003-0000-0000-C000-000000000046}
nointerface
QueryInterface
{0000001B-0000-0000-C000-000000000046}
nointerface
QueryInterface
{00000000-0000-0000-C000-000000000046}
AddRef 4
AddRef 5
QueryInterface
{00000001-0000-0000-C000-000000000046} // вот здесь не запрашивает как в пред IStdMarshal
// вместо этого снова IClassFactory
AddRef 6
Release7
CreateInstance
QueryInterface
{00000000-0000-0000-C000-000000000046}
AddRef 6
AddRef 7
QueryInterface
{00000003-0000-0000-C000-000000000046}
nointerface
QueryInterface
{0000001B-0000-0000-C000-000000000046}
nointerface
QueryInterface
{00000000-0000-0000-C000-000000000046}
AddRef 8
AddRef 9
QueryInterface
{00000001-0000-0000-C000-000000000046}
...
и дальше еще куча запросов
|
Так вот, почему дельфевая програ ведет себя по другому, и в результате не создает объект? |