759 lines
22 KiB
Plaintext
759 lines
22 KiB
Plaintext
unit utslvcl_com;
|
||
interface
|
||
(*
|
||
//20231111
|
||
//范例
|
||
步骤:
|
||
//继承 t_com_class
|
||
//重写 get_clsid
|
||
//重写 get_com_name
|
||
//重写 invoke_param_is_excel
|
||
//重写 execute_retun_is_excel
|
||
//重写 invoke_call
|
||
//重写 install_for_all_users
|
||
//编译成exe
|
||
//安装 名称.exe -install
|
||
//卸载 名称.exe -uninstall
|
||
//************脚本范例,编译该脚本为exe***************************
|
||
com := new my_com();
|
||
return com.do_command();
|
||
type my_com=class(t_com_class)
|
||
function create();
|
||
begin
|
||
inherited;
|
||
end
|
||
function get_clsid();virtual; //配置clsid
|
||
begin
|
||
return "{F59A8177-02A0-4019-A393-AF079F9AB365}";
|
||
end
|
||
function get_com_name();virtual; //配置名称
|
||
begin
|
||
return "mycom.test";
|
||
end
|
||
end
|
||
*)
|
||
uses tslvcl;
|
||
type t_com_class = class()
|
||
private
|
||
theFactory;
|
||
dwRegister;
|
||
sguid;
|
||
fapp;
|
||
public
|
||
function create();
|
||
begin
|
||
end
|
||
function get_clsid();virtual; //配置clsid
|
||
begin
|
||
return "{F59A8177-02A0-4019-A393-AF079F9AB362}";
|
||
//raise "clsid err";
|
||
end
|
||
function get_com_name();virtual; //配置名称
|
||
begin
|
||
return "tscomctl.test";
|
||
//raise "com name err";
|
||
end
|
||
function invoke_param_is_excel(fname);virtual; //执行时候参数是否为excel格式
|
||
begin
|
||
return false;
|
||
end
|
||
function execute_retun_is_excel(fname);virtual;//返回时候参数是否为excel格式
|
||
begin
|
||
return false;
|
||
end
|
||
function invoke_call(fname,pms);virtual; //执行函数
|
||
begin
|
||
return callinarray(findfunction(fname),pms);
|
||
end
|
||
function COINIT_Param();virtual; //启动参数
|
||
begin
|
||
return 0;
|
||
end
|
||
function install_check();virtual; //安装前检查
|
||
begin
|
||
return true;
|
||
end
|
||
function install_for_all_users();virtual; //是否安装到本地为所有人使用
|
||
begin
|
||
return false;
|
||
end
|
||
function stop_run(); //停止
|
||
begin
|
||
fapp._wapi.PostQuitMessage(0);
|
||
end
|
||
function do_command();//执行
|
||
begin
|
||
for i:= 0 to sysparamcount() do
|
||
begin
|
||
si := sysparamstr(i);
|
||
if si="-Embedding" or si= "/Embedding" then
|
||
begin
|
||
return run_com();
|
||
end
|
||
if si="-install" then
|
||
begin
|
||
return do_install();
|
||
end
|
||
if si="-uninstall" then
|
||
begin
|
||
return do_uninstall();
|
||
end
|
||
end
|
||
end
|
||
function install_success();virtual;
|
||
begin
|
||
echo "步骤：安装完成！\r\n\r\n";
|
||
end
|
||
function uninstall_success();virtual;
|
||
begin
|
||
echo "步骤：卸载完成！\r\n\r\n";
|
||
end
|
||
private
|
||
function do_install();
|
||
begin
|
||
do_install_sub();
|
||
echo "\r\n输入回车键退出";
|
||
s := readln();
|
||
end
|
||
function do_uninstall();
|
||
begin
|
||
do_uninstall_sub();
|
||
echo "\r\n输入回车键退出";
|
||
s := readln();
|
||
end
|
||
function do_install_sub();
|
||
begin
|
||
if not install_check() then
|
||
begin
|
||
echo "提示：安装检查失败。\r\n";
|
||
return ;
|
||
end
|
||
dllclsid := get_clsid();
|
||
subid := "LocalServer32";
|
||
comname := get_com_name();
|
||
dllPath := sysexecname();
|
||
rk := get_classes_key();
|
||
if not ifobj(rk) then
|
||
begin
|
||
echo "警告：请使用管理员权限执行CMD。\r\n";
|
||
return;
|
||
end
|
||
tkpath := rk.openKeyA("CLSID\\"+dllclsid+"\\"+subid);
|
||
tkname := rk.openKeyA(comname+"\\CLSID");
|
||
if 0=tkpath.SetValueStringA(nil,dllPath) then
|
||
begin
|
||
echo "步骤：注册执行程序成功。\r\n";
|
||
end
|
||
else
|
||
begin
|
||
echo "步骤：注册执行程序失败。\r\n";
|
||
return ;
|
||
end
|
||
if 0= tkname.SetValueStringA(nil,dllclsid) then
|
||
begin
|
||
echo "步骤：写入clsid成功。\r\n";
|
||
end else
|
||
begin
|
||
echo "警告：写入clsid失败。\r\n";
|
||
return ;
|
||
end
|
||
install_success();
|
||
end
|
||
function get_classes_key(); //
|
||
begin
|
||
if install_for_all_users() then //安装到本机
|
||
begin
|
||
rk := new TRegKey(class(TRegKey).HKEY_LOCAL_MACHINE);
|
||
end else //安装到当前用户
|
||
begin
|
||
rk := new TRegKey(class(TRegKey).HKEY_CURRENT_USER);
|
||
end
|
||
return rk.openKeyA("Software\\Classes");
|
||
end
|
||
function do_uninstall_sub();
|
||
begin
|
||
dllclsid := get_clsid();
|
||
comname := get_com_name();
|
||
rk := get_classes_key();
|
||
if not ifobj(rk) then
|
||
begin
|
||
echo "警告：请使用管理员权限执行。\r\n";
|
||
return;
|
||
end
|
||
else
|
||
begin
|
||
id := rk.openKeyA(comname+"\\CLSID").GetValueA();
|
||
if not ifstring(id) then
|
||
begin
|
||
echo "警告：没有安装,不需要卸载！\r\n";
|
||
return ;
|
||
end
|
||
if rk.DeleteTreeA(comname)=0 then
|
||
begin
|
||
echo "步骤：注册表删除com名成功！\r\n";
|
||
|
||
end else
|
||
begin
|
||
echo "警告：删除注册表com名失败！\r\n";
|
||
return 0;
|
||
end
|
||
if rk.DeleteTreeA("CLSID\\"+dllclsid)=0 then
|
||
begin
|
||
echo "步骤：注册表删除clsid成功！\r\n";
|
||
|
||
end else
|
||
begin
|
||
echo "警告：删除注册clsid表失败！\r\n";
|
||
return 0;
|
||
end
|
||
uninstall_success();
|
||
return ;
|
||
end
|
||
end
|
||
function run_com(); //运行
|
||
begin
|
||
if not fapp then
|
||
begin
|
||
fapp := initializeapplication();
|
||
end
|
||
WSAStartup(0,0);
|
||
CoInitializeEx(0,COINIT_Param());
|
||
RegisterFactory();
|
||
fapp.run();
|
||
UnregisterFactory();
|
||
end
|
||
function RegisterFactory(); //执行注册
|
||
begin
|
||
theFactory := new IClassFactory();
|
||
theFactory.fcom_mgr := self(true);
|
||
pUnkForFactory := theFactory._getptr_();
|
||
v := 0;
|
||
dwRegister := 0;
|
||
CoRegisterClassObject(getguid()._getptr_,pUnkForFactory,4,1,v);
|
||
dwRegister:= v;
|
||
end
|
||
procedure UnregisterFactory(); //执行退出
|
||
begin
|
||
if dwRegister<>0 then
|
||
begin
|
||
CoRevokeClassObject(dwRegister);
|
||
end
|
||
{if theFactory then
|
||
begin
|
||
theFactory.release();
|
||
end }
|
||
theFactory := nil;
|
||
end
|
||
function getguid();
|
||
begin
|
||
if not sguid then
|
||
begin
|
||
sguid := new tguid();
|
||
sguid.readstr(get_clsid());
|
||
end
|
||
return sguid;
|
||
end
|
||
end
|
||
implementation
|
||
type tcom_const = class
|
||
static const E_NOTIMPL=0x80004001L;
|
||
static const E_NOINTERFACE=0x80004002L;
|
||
static const E_INVALIDARG=0x80070057L;
|
||
{
|
||
static const VT_EMPTY = 0;
|
||
static const VT_NULL = 1;
|
||
static const VT_I2 = 2;
|
||
static const VT_I4 = 3;
|
||
static const VT_R4 = 4;
|
||
static const VT_R8 = 5;
|
||
static const VT_CY = 6;
|
||
static const VT_DATE = 7;
|
||
static const VT_BSTR = 8;
|
||
static const VT_DISPATCH = 9;
|
||
static const VT_ERROR = 10;
|
||
static const VT_BOOL = 11;
|
||
static const VT_VARIANT = 12;
|
||
static const VT_UNKNOWN = 13;
|
||
static const VT_DECIMAL = 14;
|
||
static const VT_I1 = 16;
|
||
static const VT_UI1 = 17;
|
||
static const VT_UI2 = 18;
|
||
static const VT_UI4 = 19;
|
||
static const VT_I8 = 20;
|
||
static const VT_UI8 = 21;
|
||
static const VT_INT = 22;
|
||
static const VT_UINT = 23;
|
||
static const VT_VOID = 24;
|
||
static const VT_HRESULT = 25;
|
||
static const VT_PTR = 26;
|
||
static const VT_SAFEARRAY = 27;
|
||
static const VT_CARRAY = 28;
|
||
static const VT_USERDEFINED = 29;
|
||
static const VT_LPSTR = 30;
|
||
static const VT_LPWSTR = 31;
|
||
static const VT_RECORD = 36;
|
||
static const VT_INT_PTR = 37;
|
||
static const VT_UINT_PTR = 38;
|
||
static const VT_FILETIME = 64;
|
||
static const VT_BLOB = 65;
|
||
static const VT_STREAM = 66;
|
||
static const VT_STORAGE = 67;
|
||
static const VT_STREAMED_OBJECT = 68;
|
||
static const VT_STORED_OBJECT = 69;
|
||
static const VT_BLOB_OBJECT = 70;
|
||
static const VT_CF = 71;
|
||
static const VT_CLSID = 72;
|
||
static const VT_VERSIONED_STREAM = 73;
|
||
static const VT_BSTR_BLOB = 0xfff;
|
||
static const VT_VECTOR = 0x1000;
|
||
static const VT_ARRAY = 0x2000;
|
||
static const VT_BYREF = 0x4000;
|
||
static const VT_RESERVED = 0x8000;
|
||
static const VT_ILLEGAL = 0xffff;
|
||
static const VT_ILLEGALMASKED = 0xfff;
|
||
static const VT_TYPEMASK = 0xfff;
|
||
}
|
||
|
||
end
|
||
|
||
type tguid=class(tslcstructureobj)
|
||
uses cstructurelib;
|
||
private
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("data1","int",0xf59a8177),
|
||
("data2","short",0x2a0),
|
||
("data3","short",0x4019),
|
||
("data4","byte[8]",array(0xa3, 0x93, 0xaf, 0x7, 0x9f, 0x9a, 0xb3, 0x62)),
|
||
)
|
||
);
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
function readstr(s);
|
||
begin
|
||
r := __getid(s);
|
||
_setvalue_("data1",r[0]);
|
||
_setvalue_("data2",r[1]);
|
||
_setvalue_("data3",r[2]);
|
||
_setvalue_("data4",r[3:]);
|
||
end
|
||
function __getid(clsid);
|
||
begin
|
||
//clsid := getmycomregclsid(); //"{F59A8177-02A0-4019-A393-AF079F9AB361}";
|
||
r := zeros(11);
|
||
guidinfo := array(8,4,4,2,2,2,2,2,2,2,2);
|
||
num := inttostr(0->9);
|
||
sym := array("A","B","C","D","E","F");
|
||
hs := array();
|
||
for i,v in num do hs[v] := true;
|
||
for i,v in sym do hs[v] := true;
|
||
for i,v in lowercase(sym) do hs[v] := true;
|
||
idx := 0;
|
||
vvi := "";
|
||
for i:= 1 to length(clsid) do
|
||
begin
|
||
vi := clsid[i];
|
||
if length(vvi)=guidinfo[idx] then
|
||
begin
|
||
r[idx] := eval(&("0x"+vvi));
|
||
idx++;
|
||
vvi := "";
|
||
end
|
||
if not(hs[vi]) then continue;
|
||
vvi+=vi;
|
||
end
|
||
return r;
|
||
end
|
||
function equ(riid);
|
||
begin
|
||
if ifarray(riid) then
|
||
begin
|
||
return _getdata_()=riid ;
|
||
end
|
||
if riid>0 then
|
||
begin
|
||
d := _getdata_();
|
||
o := new tguid(riid);
|
||
return d=o._getdata_();
|
||
end
|
||
return false;
|
||
end
|
||
end
|
||
|
||
type tagVARIANT =class(tslcstructureobj)
|
||
uses cstructurelib;
|
||
private
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("vt","short",0),
|
||
("wReserved1","short",0),
|
||
("wReserved2","short",0),
|
||
("wReserved3","short",0),
|
||
("data","intptr",0),
|
||
("data2","intptr",0)
|
||
)
|
||
);
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
end
|
||
type tagDISPPARAMS = class(tslcstructureobj)
|
||
uses cstructurelib;
|
||
private
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("rgvarg","intptr",0),
|
||
("rgdispidNamedArgs","intptr",0),
|
||
("cArgs","int",0),
|
||
("cNamedArgs","int",0)
|
||
)
|
||
);
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
function getarg(idx);
|
||
begin
|
||
if (idx >=0) and (idx<_getvalue_("cArgs")) then
|
||
begin
|
||
addri := _getvalue_("rgvarg");
|
||
obj := new tagVARIANT(addri);
|
||
if idx>0 then
|
||
begin
|
||
addri := int64(addri+idx*obj._size_()); //_tool.readptr(addri+idx*8);
|
||
obj._setcptr_(addri);
|
||
end
|
||
return obj;
|
||
end
|
||
end
|
||
function getArgs(od);
|
||
begin
|
||
r := array();
|
||
ct := _getvalue_("cArgs");
|
||
if ct<1 then return r;
|
||
addri := _getvalue_("rgvarg");
|
||
obj := new tagVARIANT(addri);
|
||
r[0] := obj;
|
||
sz := obj._size_();
|
||
for i:= 1 to ct-1 do
|
||
begin
|
||
addri+=sz;
|
||
r[i] := new tagVARIANT(addri);
|
||
end
|
||
if not od then
|
||
begin
|
||
rt := array();
|
||
idx := 0;
|
||
for i:= ct-1 downto 0 do
|
||
begin
|
||
rt[idx++] := r[i];
|
||
end
|
||
return rt;
|
||
end
|
||
return r;
|
||
end
|
||
property cArgs index "cArgs" read _getvalue_;
|
||
end
|
||
type tptrarray =class(tslcstructureobj)
|
||
uses cstructurelib;
|
||
private
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("ptr","intptr",0)
|
||
)
|
||
);
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
function ansistr();
|
||
begin
|
||
p := _getvalue_("ptr");
|
||
wlen := uaw_wcslen(p);
|
||
sansi := "";
|
||
setlength(sansi,wlen*2+1);
|
||
WideCharToMultiByte(0,0,p,wlen,sansi,length(sansi),0,0);
|
||
return sansi;
|
||
end
|
||
end
|
||
|
||
type iunkown =class(tslcstructureobj,tcom_const)
|
||
uses cstructurelib;
|
||
private
|
||
static SSTRUCT;
|
||
protected
|
||
static IID_IUnknown ;//:= new tguid();
|
||
static IID_IClassFactory;// := new tguid();
|
||
static IID_IDispatch;// := new tguid();
|
||
m_dwRef;
|
||
fvtable;
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then
|
||
begin
|
||
IID_IUnknown := new tguid();
|
||
IID_IClassFactory := new tguid();
|
||
IID_IDispatch := new tguid();
|
||
IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
|
||
IID_IClassFactory.readstr("{00000001-0000-0000-C000-000000000046}");
|
||
IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");
|
||
|
||
SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("vtable","intptr",0)
|
||
)
|
||
);
|
||
end
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
function addref(s:pointer):integer;stdcall;
|
||
begin
|
||
m_dwRef++;
|
||
//echo "\r\nidispath addref:",s,"====",m_dwRef;
|
||
return m_dwRef;
|
||
end
|
||
function release(s:pointer):integer;stdcall;virtual;
|
||
begin
|
||
if m_dwRef>0 then m_dwRef--;
|
||
return m_dwRef;
|
||
end
|
||
end
|
||
type dispatchvtable =class(tslcstructureobj)
|
||
uses cstructurelib;
|
||
private
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("QueryInterface","intptr",0),
|
||
("AddRef","intptr",0),
|
||
("Release","intptr",0),
|
||
("GetTypeInfoCount","intptr",0),
|
||
("GetTypeInfo","intptr",0),
|
||
("GetIDsOfNames","intptr",0),
|
||
("Invoke","intptr",0)
|
||
)
|
||
);
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
end
|
||
type idispatch=class(iunkown)
|
||
private
|
||
frgDispIds;
|
||
frgDispIds2;
|
||
function getdispid(s);
|
||
begin
|
||
id := frgDispIds[s];
|
||
if id>0 then
|
||
begin
|
||
return id;
|
||
end
|
||
id := length(frgDispIds);
|
||
frgDispIds2[id] := s;
|
||
frgDispIds[s] := id;
|
||
end
|
||
function getdispidstr(id);
|
||
begin
|
||
return frgDispIds2[id];
|
||
end
|
||
public
|
||
[weakref] fcom_mgr;
|
||
function create(ptr)
|
||
begin
|
||
inherited ;//create(getstruct(),ptr);
|
||
if not ptr then
|
||
begin
|
||
fvtable := new dispatchvtable();
|
||
_setvalue_("vtable",fvtable._getptr_());
|
||
fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
|
||
fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
|
||
fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
|
||
fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));
|
||
fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));
|
||
fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));
|
||
fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));
|
||
end else
|
||
begin
|
||
fvtable := new fvtable(_getvalue_("vtable"));
|
||
m_dwRef := 0;
|
||
end
|
||
frgDispIds := array();
|
||
frgDispIds2 := array();
|
||
end
|
||
function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;
|
||
begin
|
||
pctinfo := 0;
|
||
return 0;
|
||
end
|
||
function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;
|
||
begin
|
||
if ppTInfo then ppTInfo := 0;
|
||
return E_NOTIMPL;
|
||
end
|
||
function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;
|
||
begin
|
||
if cnames>1 then return E_INVALIDARG;
|
||
ostr := new tptrarray(rgszNames);
|
||
rgDispId := getdispid(ostr.ansistr);
|
||
return 0;
|
||
end
|
||
function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer; pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;
|
||
begin
|
||
o := new tagDISPPARAMS(pDispParams);
|
||
pp := o.getArgs();
|
||
pms := array();
|
||
fname := getdispidstr(dispIdMember);
|
||
for idx,p1 in pp do
|
||
begin
|
||
VariantToObj2(TS_GetGlobalL(),p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
|
||
pms[idx] := r;
|
||
end
|
||
x := fcom_mgr.invoke_call(fname,pms);
|
||
ObjToVariantRef(TS_GetGlobalL(),x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
|
||
return 0;
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;
|
||
begin
|
||
if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then
|
||
begin
|
||
ppv := _getptr_();
|
||
addref(ppv);
|
||
return 0;
|
||
end
|
||
return E_NOINTERFACE;
|
||
end
|
||
|
||
function release(s:pointer):integer;stdcall;override;
|
||
begin
|
||
r := inherited;
|
||
//echo "\r\nidispath release:",s,"====",r;
|
||
if r=0 and fcom_mgr then fcom_mgr.stop_run();
|
||
return r;
|
||
end
|
||
end
|
||
type ClassFactoryvtable = class(tslcstructureobj)
|
||
uses cstructurelib;
|
||
private
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("QueryInterface","intptr",0),
|
||
("AddRef","intptr",0),
|
||
("Release","intptr",0),
|
||
("CreateInstance","intptr",0),
|
||
("LockServer","intptr",0)
|
||
)
|
||
);
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
end
|
||
type IClassFactory=class(iunkown)
|
||
static sguid;
|
||
private
|
||
static dwRegister;
|
||
static theFactory;
|
||
fdispatchs;
|
||
public
|
||
[weakref] fcom_mgr;
|
||
function create(ptr);override;
|
||
begin
|
||
inherited ;
|
||
fdispatchs := array();
|
||
if not ptr then
|
||
begin
|
||
fvtable := new ClassFactoryvtable();
|
||
_setvalue_("vtable",fvtable._getptr_());
|
||
fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
|
||
fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
|
||
fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
|
||
fvtable._setvalue_("CreateInstance",makeinstance(thisfunction(CreateInstance)));
|
||
fvtable._setvalue_("LockServer",makeinstance(thisfunction(LockServer)));
|
||
|
||
end else
|
||
begin
|
||
fvtable := new fvtable(_getvalue_("vtable"));
|
||
m_dwRef := 0;
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;
|
||
begin
|
||
if IID_IUnknown.equ(riid) or IID_IClassFactory.equ(riid) then
|
||
begin
|
||
ppv := _getptr_();
|
||
addref(ppv);
|
||
return 0;
|
||
end
|
||
return E_NOINTERFACE;
|
||
end
|
||
function release(s:pointer):integer;stdcall;override;
|
||
begin
|
||
r := inherited;
|
||
//echo "\r\nIClassFactory release:",s,"====",r;
|
||
return r;
|
||
end
|
||
function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;//
|
||
begin
|
||
if not fdispatchs then
|
||
begin
|
||
fdispatchs := new idispatch();
|
||
fdispatchs.fcom_mgr := fcom_mgr;
|
||
end
|
||
hr := fdispatchs.QueryInterface(fdispatchs._getptr_(),riid,ppvObject);
|
||
return hr;
|
||
end
|
||
function LockServer(lk:integer):integer;stdcall;
|
||
begin
|
||
return 1;
|
||
end
|
||
end
|
||
|
||
|
||
function CoRegisterClassObject(rclsid:pointer;pUnk:pointer;dwClsContext:integer;flags:integer;var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRegisterClassObject";
|
||
function CoRevokeClassObject(var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRevokeClassObject";
|
||
function WSAStartup(q:short;d:pointer):integer; stdcall; external "Ws2_32.dll" name "WSAStartup";
|
||
function CoInitializeEx(q:pointer;d:integer):integer; stdcall; external "ole32.dll" name "CoInitializeEx";
|
||
procedure VariantToObj2(L:pointer; V:pointer; var o:TObject;isIndex:integer);cdecl;external "tslkrnl.dll" name "VariantToObj2";
|
||
procedure ObjToVariantRef(L:pointer;o:TObject; v:pointer; IsExcel:integer);cdecl;external "tslkrnl.dll" name "ObjToVariantRef";
|
||
function TS_GetGlobalL():pointer;cdecl;external "TSSVRAPI.dll" name "TS_GetGlobalL";
|
||
function uaw_wcslen(s:pointer):integer;stdcall;external "Kernel32.dll" name "uaw_wcslen";
|
||
function WideCharToMultiByte(CodePage:integer;dwFlags:integer;lpWideCharStr:pointer;
|
||
cchWideChar:integer;var lpMultiByteStr:string;cbMultiByte:integer;
|
||
lpDefaultChar:pointer;var lpUsedDefaultChar:integer):integer;stdcall;external "Kernel32.dll" name "WideCharToMultiByte";
|
||
|
||
|
||
|
||
|
||
initialization
|
||
end. |