JianjunLiu
parent
7406cfb299
commit
2f98f9a684
|
|
@ -0,0 +1,751 @@
|
|||
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_for_all_users(); //是否安装到本地为所有人使用
|
||||
begin
|
||||
return false;
|
||||
end
|
||||
function stop_run(); //停止
|
||||
begin
|
||||
fapp._wapi.PostQuitMessage(0);
|
||||
end
|
||||
function do_command();//执行
|
||||
begin
|
||||
for i:= 0 to sysparamcount() do
|
||||
begin
|
||||
//"-Embedding") == 0) || (_stricmp(lpCmdLine, "/Embedding"
|
||||
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
|
||||
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.
|
||||
Loading…
Reference in New Issue