1044 lines
31 KiB
Plaintext
1044 lines
31 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)
|
||
uses utslvcl_com;
|
||
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 cstructurelib,tslvcl;
|
||
function sh_get_IShellLinkW(); //获取快捷方式创建接口
|
||
function create_short_cutA(targ,lnk);//创建文件快捷方式
|
||
type inukownvtb = class(tslcstructureobj)
|
||
function create(ptr);
|
||
begin
|
||
struct := MemoryAlignmentCalculate(get_vtb_struct());
|
||
inherited create(struct,ptr);
|
||
end
|
||
protected
|
||
function get_vtb_struct();virtual;
|
||
begin
|
||
return array(
|
||
("QueryInterface","intptr",0),
|
||
("AddRef","intptr",0),
|
||
("Release","intptr",0)
|
||
);
|
||
end
|
||
end
|
||
type idispatchvtb =class(inukownvtb)
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited ;
|
||
end
|
||
protected
|
||
function get_vtb_struct();override;
|
||
begin
|
||
return inherited union array(
|
||
("GetTypeInfoCount","intptr",0),
|
||
("GetTypeInfo","intptr",0),
|
||
("GetIDsOfNames","intptr",0),
|
||
("Invoke","intptr",0)
|
||
);
|
||
end
|
||
end
|
||
type iClassFactoryvtb =class(inukownvtb)
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited ;
|
||
end
|
||
protected
|
||
function get_vtb_struct();override;
|
||
begin
|
||
return inherited union array(
|
||
("CreateInstance","intptr",0),
|
||
("LockServer","intptr",0)
|
||
);
|
||
end
|
||
end
|
||
type tclsguid = class(tguid) //clsid对象
|
||
function create(ptr);
|
||
begin
|
||
inherited;
|
||
end
|
||
end
|
||
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
|
||
//sleep(10000);
|
||
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\n10秒后退出";
|
||
sleep(10000);
|
||
//s := readln();
|
||
end
|
||
function do_uninstall();
|
||
begin
|
||
do_uninstall_sub();
|
||
echo "\r\n10秒后退出";
|
||
sleep(10000);
|
||
//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)
|
||
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 asstr(); //转换为
|
||
begin
|
||
r := _getdata_();
|
||
s := "{";
|
||
s += format("%8X",R["data1"]);
|
||
s+="-";
|
||
s += format("%4X",R["data2"]);
|
||
s+="-";
|
||
s += format("%4X",R["data3"]);
|
||
s+="-";
|
||
for i:= 0 to 1 do
|
||
begin
|
||
s+=format("%2x",r["data4",i]);
|
||
end
|
||
s+="-";
|
||
for i:= 2 to 7 do
|
||
begin
|
||
s+=format("%2x",r["data4",i]);
|
||
end
|
||
s+="}";
|
||
return replacetext(s," ","0");
|
||
end
|
||
function equ(riid); //相等
|
||
begin
|
||
if ifstring(riid) then return asstr()=riid;
|
||
if ifarray(riid) then
|
||
begin
|
||
return _getdata_()=riid ;
|
||
end
|
||
if riid>0 or riid<0 then
|
||
begin
|
||
d := _getdata_();
|
||
o := new tguid(riid);
|
||
return d=o._getdata_();
|
||
end
|
||
return false;
|
||
end
|
||
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
|
||
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
|
||
end
|
||
|
||
type tagVARIANT =class(tslcstructureobj)
|
||
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)
|
||
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)
|
||
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
|
||
//////////////////////////vtb/////////////////////////////
|
||
type inukownvtbcontainer = class(tslcstructureobj)
|
||
private
|
||
static SSTRUCT;
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then
|
||
begin
|
||
SSTRUCT := MemoryAlignmentCalculate(array(
|
||
("vtable","intptr",0)
|
||
)
|
||
);
|
||
end
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr);
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
end
|
||
|
||
type iunkown =class(tcom_const)
|
||
protected
|
||
static IID_IUnknown ;//:= new tguid();
|
||
m_dwRef;
|
||
fvtable;
|
||
fvtablecontainer;
|
||
function createvtb(ptr);virtual;
|
||
begin
|
||
return new inukownvtb(ptr);
|
||
end
|
||
public
|
||
function create(ptr);
|
||
begin
|
||
if not IID_IUnknown then
|
||
begin
|
||
IID_IUnknown := new tguid();
|
||
IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
|
||
end
|
||
fvtablecontainer := new inukownvtbcontainer(ptr);
|
||
if ptr then
|
||
begin
|
||
fvtable := createvtb( fvtablecontainer._getvalue_("vtable"));
|
||
end else
|
||
begin
|
||
fvtable := createvtb(nil);
|
||
fvtablecontainer._setvalue_("vtable",fvtable._getptr_());
|
||
fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
|
||
fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
|
||
fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
|
||
begin
|
||
if IID_IUnknown.equ(riid) then
|
||
begin
|
||
ppv := _getptr_();
|
||
AddRef(ppv);
|
||
return 0;
|
||
end
|
||
return E_NOINTERFACE;
|
||
end
|
||
function AddRef(s:pointer):integer;stdcall;virtual;
|
||
begin
|
||
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
|
||
function _getptr_();
|
||
begin
|
||
return fvtablecontainer._getptr_();
|
||
end
|
||
end
|
||
|
||
type idispatch=class(iunkown)
|
||
protected
|
||
static IID_IDispatch;
|
||
function createvtb(ptr);override;
|
||
begin
|
||
return new idispatchvtb(ptr);
|
||
end
|
||
public
|
||
[weakref] fcom_mgr;
|
||
function create(ptr)
|
||
begin
|
||
inherited ;//create(getstruct(),ptr);
|
||
if not IID_IDispatch then
|
||
begin
|
||
IID_IDispatch := new tguid();
|
||
IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");
|
||
end
|
||
if not ptr then
|
||
begin
|
||
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
|
||
frgDispIds := array();
|
||
frgDispIds2 := array();
|
||
end
|
||
function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
|
||
begin
|
||
pctinfo := 0;
|
||
return 0;
|
||
end
|
||
function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual;
|
||
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;virtual;
|
||
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;virtual;
|
||
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;virtual;
|
||
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;
|
||
if r=0 and fcom_mgr then fcom_mgr.stop_run();
|
||
return r;
|
||
end
|
||
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
|
||
end
|
||
|
||
type IClassFactory=class(iunkown)
|
||
static sguid;
|
||
protected
|
||
static IID_IClassFactory;// := new tguid();
|
||
function createvtb(ptr);virtual;
|
||
begin
|
||
return new iClassFactoryvtb(ptr);
|
||
end
|
||
public
|
||
[weakref] fcom_mgr;
|
||
function create(ptr);override;
|
||
begin
|
||
inherited ;
|
||
if not IID_IClassFactory then
|
||
begin
|
||
IID_IClassFactory := new tguid();
|
||
IID_IClassFactory.readstr("{00000001-0000-0000-C000-000000000046}");
|
||
end
|
||
fdispatchs := array();
|
||
if not ptr then
|
||
begin
|
||
fvtable._setvalue_("CreateInstance",makeinstance(thisfunction(CreateInstance)));
|
||
fvtable._setvalue_("LockServer",makeinstance(thisfunction(LockServer)));
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
|
||
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 CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;//
|
||
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;virtual;
|
||
begin
|
||
return 1;
|
||
end
|
||
private
|
||
static dwRegister;
|
||
static theFactory;
|
||
fdispatchs;
|
||
end
|
||
type ishelllinkavtb = class(inukownvtb)
|
||
function create(ptr);
|
||
begin
|
||
inherited;
|
||
end
|
||
protected
|
||
function get_vtb_struct();override;
|
||
begin
|
||
return inherited union array(
|
||
("GetPath","intptr",0),
|
||
("GetIDList","intptr",0),
|
||
("SetIDList","intptr",0),
|
||
("GetDescription","intptr",0),
|
||
("SetDescription","intptr",0),
|
||
("GetWorkingDirectory","intptr",0),
|
||
("SetWorkingDirectory","intptr",0),
|
||
("GetArguments","intptr",0),
|
||
("SetArguments","intptr",0),
|
||
("GetHotkey","intptr",0),
|
||
("SetHotkey","intptr",0),
|
||
("GetShowCmd","intptr",0),
|
||
("SetShowCmd","intptr",0),
|
||
("GetIconLocation","intptr",0),
|
||
("SetIconLocation","intptr",0),
|
||
("SetRelativePath","intptr",0),
|
||
("Resolve","intptr",0),
|
||
("SetPath","intptr",0)
|
||
);
|
||
end
|
||
end
|
||
type iPersistFilevtb = class(inukownvtb)
|
||
function create(ptr);
|
||
begin
|
||
inherited;
|
||
end
|
||
protected
|
||
function get_vtb_struct();override;
|
||
begin
|
||
return inherited union array(
|
||
("GetClassID","intptr",0),
|
||
("IsDirty","intptr",0),
|
||
("Load","intptr",0),
|
||
("Save","intptr",0),
|
||
("SaveCompleted","intptr",0),
|
||
("GetCurFile","intptr",0)
|
||
);
|
||
end
|
||
end
|
||
type IShellLink=class(iunkown) //"000214EE-0000-0000-C000-000000000046"
|
||
protected
|
||
function createvtb(ptr);override;
|
||
begin
|
||
return new ishelllinkavtb(ptr);
|
||
end
|
||
public
|
||
function create(ptr);override;
|
||
begin
|
||
inherited ;
|
||
end
|
||
function Destroy();virtual;
|
||
begin
|
||
release(nil);
|
||
end
|
||
function AddRef(s):integer;override;
|
||
begin
|
||
f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("AddRef");
|
||
if not s then s := _getptr_();
|
||
return call(f,_getptr_());
|
||
end
|
||
function Release(s):integer;override;
|
||
begin
|
||
f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("Release"); ;
|
||
if not s then s := _getptr_();
|
||
return call(f,s);
|
||
end
|
||
function QueryInterface(s,riid,ppv):integer;virtual;
|
||
begin
|
||
f := function(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;external fvtable._getvalue_("QueryInterface");;
|
||
if not s then s := _getptr_();
|
||
return call(f,s,riid,ppv);
|
||
end
|
||
function SetPath(s:pointer;target:widestring):integer;stdcall;virtual;
|
||
begin
|
||
ptr := fvtable._getvalue_("SetPath");
|
||
f := function(s:pointer;target:widestring):integer;stdcall ;external ptr;
|
||
if not s then s := _getptr_();
|
||
R := ##f(s,target);
|
||
RETURN R;
|
||
end
|
||
function SetDescription(s:pointer;descrip:widestring):integer;stdcall;virtual;
|
||
begin
|
||
f := function(s:pointer;descrip:widestring):integer;stdcall;external fvtable._getvalue_("SetDescription");
|
||
if not s then s := _getptr_();
|
||
return call(f,s,t);
|
||
end
|
||
function get_persistfile();
|
||
begin
|
||
{**
|
||
@explan(说明) 获取 文件保存对象 %%
|
||
@return(IPersistFile) 对象 %%
|
||
**}
|
||
fclsid := new tguid();
|
||
fclsid.readstr("{0000010b-0000-0000-C000-000000000046}");
|
||
if 0<>QueryInterface(nil,fclsid._getptr_(),v2) then
|
||
begin
|
||
return -1;
|
||
end
|
||
return new IPersistFile(v2);
|
||
end
|
||
end
|
||
type IPersistFile=class(iunkown) //"0000010b-0000-0000-C000-000000000046"
|
||
protected
|
||
function createvtb(ptr);override;
|
||
begin
|
||
return new iPersistFilevtb(ptr);
|
||
end
|
||
public
|
||
function create(ptr);override;
|
||
begin
|
||
inherited ;
|
||
end
|
||
function Destroy();virtual;
|
||
begin
|
||
Release(nil);
|
||
end
|
||
function addref(s:pointer):integer;stdcall;override;
|
||
begin
|
||
ptr := fvtable._getvalue_("AddRef");
|
||
f := function(s:pointer):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
return call(f,s);
|
||
end
|
||
function Release(s:pointer):integer;stdcall;override;
|
||
begin
|
||
ptr := fvtable._getvalue_("AddRef");
|
||
f := function(s:pointer):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
return call(f,s);
|
||
|
||
end
|
||
function IsDirty(s:pointer):integer;stdcall;virtual;
|
||
begin
|
||
ptr := fvtable._getvalue_("IsDirty");
|
||
f := function(s:pointer):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
return call(f,s);
|
||
end
|
||
function Load(s:pointer;fn:widestring;md:integer):integer;stdcall;virtual;
|
||
begin
|
||
ptr := fvtable._getvalue_("Load");
|
||
f := function(s:pointer;fn:string;dwmode:integer):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
return call(f,s,fn,md);
|
||
end
|
||
function Save(s:pointer;fn:widestring;Remember:integer):integer;stdcall;virtual;
|
||
begin
|
||
ptr := fvtable._getvalue_("Save");
|
||
f := function(s:pointer;fn:widestring;remember:integer):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
r := call(f,s,fn,Remember);
|
||
return r;
|
||
end
|
||
function SaveCompleted(s:pointer;fn:widestring);
|
||
begin
|
||
ptr := fvtable._getvalue_("SaveCompleted");
|
||
f := function(s:pointer;fn:widestring):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
return call(f,s,fn);
|
||
end
|
||
function GetCurFile(s:pointer;fn:widestring);
|
||
begin
|
||
ptr := fvtable._getvalue_("GetCurFile");
|
||
f := function(fn:pointer):integer;stdcall;external ptr;
|
||
if not s then s := _getptr_();
|
||
return call(f,s,fn);
|
||
end
|
||
end
|
||
function sh_get_IShellLinkW(); //获取快捷方式创建接口
|
||
begin
|
||
{
|
||
@explan(说明) 获取快捷方式构建接口 %%
|
||
@return(IShellLink) 接口对象 %%;
|
||
}
|
||
if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
|
||
hd := int64(obj);
|
||
aic := new IShellLink(hd);
|
||
aic.addref();
|
||
cls := new tguid();
|
||
cls.readstr("{000214F9-0000-0000-C000-000000000046}");
|
||
if 0 <> aic.QueryInterface(hd,cls._getptr_(),v) then return -1;
|
||
ilink := new IShellLink(v);
|
||
return ilink;
|
||
end
|
||
function create_short_cutA(targ,lnk);//创建文件快捷方式
|
||
begin
|
||
if not fileexists("",targ) then return -1;
|
||
if not ifstring(lnk) then return -1;
|
||
ilink := sh_get_IShellLinkW();
|
||
if not ifobj(ilink) then return -1;
|
||
ilink.SetPath(nil,widestring(targ));
|
||
ifile := ilink.get_persistfile();
|
||
return ifile.save(nil,widestring(lnk),true);
|
||
///////////////////////////////////////////////////
|
||
if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
|
||
hd := int64(obj);
|
||
aic := new IShellLink(hd);
|
||
aic.addref();
|
||
cls := new tguid();
|
||
cls.readstr("{000214F9-0000-0000-C000-000000000046}");
|
||
if 0 <> aic.QueryInterface(hd,cls._getptr_(),v) then return -1;
|
||
ilink := new IShellLink(v);
|
||
ilink.SetPath(nil,widestring(targ));
|
||
fclsid := new tguid();
|
||
fclsid.readstr("{0000010b-0000-0000-C000-000000000046}");
|
||
if 0<>ilink.QueryInterface(nil,fclsid._getptr_(),v2) then
|
||
begin
|
||
return -1;
|
||
end
|
||
ifile := new IPersistFile(v2);
|
||
return ifile.save(nil,widestring(lnk),true);
|
||
end
|
||
function CoCreateInstance(rclsid:pointer;pUnk:pointer;dwClsContext:integer;riid:integer;var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoCreateInstance";
|
||
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";
|
||
function MultiByteToWideChar(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;
|
||
cchMultiByte:integer;var lpWideCharStr:pointer;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar";
|
||
initialization
|
||
end. |