liujianjun
/
tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity

Create utslvcl_com.tsf 

添加com支持
This commit is contained in:
JianjunLiu 2023-11-11 04:58:27 +08:00
parent 7406cfb299
commit 2f98f9a684
1 changed files with 751 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

751
funcext/tvclib/utslvcl_com.tsf Normal file
View File

@ -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.