2134 lines
70 KiB
Plaintext
2134 lines
70 KiB
Plaintext
unit utslvcl_com;
|
||
interface
|
||
(*
|
||
//20231111
|
||
//范例
|
||
步骤:
|
||
//继承 t_com_class
|
||
//重写 get_clsid clsid 字符串
|
||
//重写 get_com_name 名称
|
||
//重写 invoke_param_is_excel
|
||
//重写 execute_retun_is_excel
|
||
//重写 invoke_call 调用函数或者属性获取
|
||
//重写 invoke_propertyset 属性设置值
|
||
//重写 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,utslvclauxiliary,tslvcl;
|
||
function sh_get_IShellLinkW(); //获取快捷方式创建接口
|
||
function create_short_cutA(targ,lnk);//创建文件快捷方式
|
||
type tagELEMDESC_test =class(tagELEMDESC)
|
||
function create(ptr);
|
||
begin
|
||
inherited;
|
||
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 ITypeInfoVtbl =class(inukownvtb)
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited ;
|
||
end
|
||
protected
|
||
function get_vtb_struct();override;
|
||
begin
|
||
return inherited union array(
|
||
("GetTypeAttr","intptr",0),
|
||
("GetTypeComp","intptr",0),
|
||
("GetFuncDesc","intptr",0),
|
||
("GetVarDesc","intptr",0),
|
||
("GetNames","intptr",0),
|
||
("GetRefTypeOfImplType","intptr",0),
|
||
("GetImplTypeFlags","intptr",0),
|
||
("GetIDsOfNames","intptr",0),
|
||
("Invoke","intptr",0),
|
||
("GetDocumentation","intptr",0),
|
||
("GetDllEntry","intptr",0),
|
||
("GetRefTypeInfo","intptr",0),
|
||
("AddressOfMember","intptr",0),
|
||
("CreateInstance","intptr",0),
|
||
("GetMops","intptr",0),
|
||
("GetContainingTypeLib","intptr",0),
|
||
("ReleaseTypeAttr","intptr",0),
|
||
("ReleaseFuncDesc","intptr",0),
|
||
("ReleaseVarDesc","intptr",0)
|
||
);
|
||
end
|
||
end
|
||
type ITypecompVtbl =class(inukownvtb)
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
inherited ;
|
||
end
|
||
protected
|
||
function get_vtb_struct();override;
|
||
begin
|
||
return inherited union array(
|
||
("Bind","intptr",0),
|
||
("BindType","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 method_names();virtual; //函数名称
|
||
begin
|
||
|
||
end
|
||
function invoke_call(fname,pms);virtual; //执行函数
|
||
begin
|
||
return callinarray(findfunction(fname),pms);
|
||
end
|
||
function invoke_propertyset(pname,v);virtual; //属性设置
|
||
begin
|
||
echo "\r\n setproperty:",pname," ",v;
|
||
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 tagTYPEKIND = class()
|
||
static const TKIND_ENUM = 0;
|
||
static const TKIND_RECORD = ( TKIND_ENUM + 1 ) ;
|
||
static const TKIND_MODULE = ( TKIND_RECORD + 1 ) ;
|
||
static const TKIND_INTERFACE = ( TKIND_MODULE + 1 ) ;
|
||
static const TKIND_DISPATCH = ( TKIND_INTERFACE + 1 ) ;
|
||
static const TKIND_COCLASS = ( TKIND_DISPATCH + 1 ) ;
|
||
static const TKIND_ALIAS = ( TKIND_COCLASS + 1 ) ;
|
||
static const TKIND_UNION = ( TKIND_ALIAS + 1 ) ;
|
||
static const TKIND_MAX = ( TKIND_UNION + 1 );
|
||
end
|
||
type tagDESCKIND = class()
|
||
static const DESCKIND_NONE = 0;
|
||
static const DESCKIND_FUNCDESC = ( DESCKIND_NONE + 1 ) ;
|
||
static const DESCKIND_VARDESC = ( DESCKIND_FUNCDESC + 1 ) ;
|
||
static const DESCKIND_TYPECOMP = ( DESCKIND_VARDESC + 1 ) ;
|
||
static const DESCKIND_IMPLICITAPPOBJ = ( DESCKIND_TYPECOMP + 1 ) ;
|
||
static const DESCKIND_MAX = ( DESCKIND_IMPLICITAPPOBJ + 1 );
|
||
|
||
end
|
||
|
||
type tagTYPEFLAGS = class()
|
||
static const TYPEFLAG_FAPPOBJECT = 0x1;
|
||
static const TYPEFLAG_FCANCREATE = 0x2;
|
||
static const TYPEFLAG_FLICENSED = 0x4;
|
||
static const TYPEFLAG_FPREDECLID = 0x8;
|
||
static const TYPEFLAG_FHIDDEN = 0x10;
|
||
static const TYPEFLAG_FCONTROL = 0x20;
|
||
static const TYPEFLAG_FDUAL = 0x40;
|
||
static const TYPEFLAG_FNONEXTENSIBLE = 0x80;
|
||
static const TYPEFLAG_FOLEAUTOMATION = 0x100;
|
||
static const TYPEFLAG_FRESTRICTED = 0x200;
|
||
static const TYPEFLAG_FAGGREGATABLE = 0x400;
|
||
static const TYPEFLAG_FREPLACEABLE = 0x800;
|
||
static const TYPEFLAG_FDISPATCHABLE = 0x1000;
|
||
static const TYPEFLAG_FREVERSEBIND = 0x2000;
|
||
static const TYPEFLAG_FPROXY = 0x4000;
|
||
end
|
||
|
||
type tagFUNCFLAGS=class() //https://learn.microsoft.com/zh-cn/windows/win32/api/oaidl/ne-oaidl-funcflags
|
||
static const FUNCFLAG_FRESTRICTED = 0x1; //此函数不应该是可从宏语言访问的。 此标志适用于系统级函数或类型浏览器不应显示的函数。
|
||
static const FUNCFLAG_FSOURCE = 0x2; //该函数返回一个对象，此对象为事件的源。
|
||
static const FUNCFLAG_FBINDABLE = 0x4; //支持数据绑定的函数。
|
||
static const FUNCFLAG_FREQUESTEDIT = 0x8; //设置后，对设置属性的方法的任何调用首先会导致对 IPropertyNotifySink：：OnRequestEdit 的调用。 OnRequestEdit 的实现确定是否允许调用来设置 属性。
|
||
static const FUNCFLAG_FDISPLAYBIND = 0x10; //作为可绑定函数显示给用户的函数。 还必须设置FUNC_FBINDABLE。
|
||
static const FUNCFLAG_FDEFAULTBIND = 0x20; //最佳表示此对象的函数。 类型信息中只有一个函数可以具有此特性。
|
||
static const FUNCFLAG_FHIDDEN = 0x40;// 不应将此函数显示给用户，尽管它存在并且为可绑定函数。
|
||
static const FUNCFLAG_FUSESGETLASTERROR = 0x80; //函数支持 GetLastError。 如果在函数期间发生错误，调用方可以调用 GetLastError 来检索错误代码。
|
||
static const FUNCFLAG_FDEFAULTCOLLELEM = 0x100;
|
||
static const FUNCFLAG_FUIDEFAULT = 0x200;
|
||
static const FUNCFLAG_FNONBROWSABLE = 0x400;
|
||
static const FUNCFLAG_FREPLACEABLE = 0x800;
|
||
static const FUNCFLAG_FIMMEDIATEBIND = 0x1000;
|
||
end
|
||
type tagVARFLAGS= class()
|
||
static const VARFLAG_FREADONLY = 0x1; //不应允许给该变量赋值
|
||
static const VARFLAG_FSOURCE = 0x2;
|
||
static const VARFLAG_FBINDABLE = 0x4;
|
||
static const VARFLAG_FREQUESTEDIT = 0x8;
|
||
static const VARFLAG_FDISPLAYBIND = 0x10;
|
||
static const VARFLAG_FDEFAULTBIND = 0x20;
|
||
static const VARFLAG_FHIDDEN = 0x40;
|
||
static const VARFLAG_FRESTRICTED = 0x80;
|
||
static const VARFLAG_FDEFAULTCOLLELEM = 0x100;
|
||
static const VARFLAG_FUIDEFAULT = 0x200;
|
||
static const VARFLAG_FNONBROWSABLE = 0x400;
|
||
static const VARFLAG_FREPLACEABLE = 0x800;
|
||
static const VARFLAG_FIMMEDIATEBIND = 0x1000;
|
||
|
||
end
|
||
type tagCALLCONV = class
|
||
static const CC_FASTCALL = 0;
|
||
static const CC_CDECL = 1;
|
||
static const CC_MSCPASCAL = ( CC_CDECL + 1 ) ;
|
||
static const CC_PASCAL = CC_MSCPASCAL;
|
||
static const CC_MACPASCAL = ( CC_PASCAL + 1 ) ;
|
||
static const CC_STDCALL = ( CC_MACPASCAL + 1 ) ;
|
||
static const CC_FPFASTCALL = ( CC_STDCALL + 1 ) ;
|
||
static const CC_SYSCALL = ( CC_FPFASTCALL + 1 ) ;
|
||
static const CC_MPWCDECL = ( CC_SYSCALL + 1 ) ;
|
||
static const CC_MPWPASCAL = ( CC_MPWCDECL + 1 ) ;
|
||
static const CC_MAX = ( CC_MPWPASCAL + 1 ) ;
|
||
end
|
||
type tagFUNCKIND = class
|
||
static const FUNC_VIRTUAL = 0;
|
||
static const FUNC_PUREVIRTUAL = ( FUNC_VIRTUAL + 1 ) ;
|
||
static const FUNC_NONVIRTUAL = ( FUNC_PUREVIRTUAL + 1 ) ;
|
||
static const FUNC_STATIC = ( FUNC_NONVIRTUAL + 1 ) ;
|
||
static const FUNC_DISPATCH = ( FUNC_STATIC + 1 ) ;
|
||
|
||
end
|
||
type DISPID_TYPE = class
|
||
static const DISPID_UNKNOWN = -1;
|
||
static const DISPID_VALUE = 0;
|
||
static const DISPID_PROPERTYPUT = -3;
|
||
static const DISPID_NEWENUM = -4;
|
||
static const DISPID_EVALUATE = -5;
|
||
static const DISPID_CONSTRUCTOR = -6;
|
||
static const DISPID_DESTRUCTOR = -7;
|
||
static const DISPID_COLLECT = -8;
|
||
end
|
||
type tagINVOKEKIND =class
|
||
static const INVOKE_FUNC = 1;
|
||
static const INVOKE_PROPERTYGET = 2;
|
||
static const INVOKE_PROPERTYPUT = 4;
|
||
static const INVOKE_PROPERTYPUTREF = 8;
|
||
end
|
||
type tagVARKIND = class
|
||
static const VAR_PERINSTANCE = 0;
|
||
static const VAR_STATIC = ( VAR_PERINSTANCE + 1 ) ;
|
||
static const VAR_CONST = ( VAR_STATIC + 1 ) ;
|
||
static const VAR_DISPATCH = ( VAR_CONST + 1 ) ;
|
||
|
||
end
|
||
type tagvtype =class
|
||
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 tagwinerr =class
|
||
static const E_UNEXPECTED = 0x8000FFFFL;
|
||
static const E_NOTIMPL=0x80004001L;
|
||
static const E_NOINTERFACE=0x80004002L;
|
||
static const E_INVALIDARG=0x80070057L;
|
||
static const E_OUTOFMEMORY=0x8007000EL;
|
||
static const E_POINTER=0x80004003L;
|
||
static const E_HANDLE=0x80070006L;
|
||
static const E_ABORT=0x80004004L;
|
||
static const E_FAIL=0x80004005L;
|
||
static const E_ACCESSDENIED=0x80070005L;
|
||
static const S_OK = 0;
|
||
end
|
||
type FACILITY_DISPATCH = class
|
||
// FACILITY_DISPATCH
|
||
// MessageId: DISP_E_UNKNOWNINTERFACE
|
||
// Unknown interface.
|
||
static const DISP_E_UNKNOWNINTERFACE =0x80020001L;
|
||
// MessageId: DISP_E_MEMBERNOTFOUND
|
||
// Member not found.
|
||
static const DISP_E_MEMBERNOTFOUND =0x80020003L;
|
||
// MessageId: DISP_E_PARAMNOTFOUND
|
||
// MessageText:
|
||
// Parameter not found.
|
||
static const DISP_E_PARAMNOTFOUND =0x80020004L;
|
||
// MessageId: DISP_E_TYPEMISMATCH
|
||
// MessageText:
|
||
// Type mismatch.
|
||
static const DISP_E_TYPEMISMATCH =0x80020005L;
|
||
// MessageId: DISP_E_UNKNOWNNAME
|
||
// MessageText:
|
||
// Unknown name.
|
||
static const DISP_E_UNKNOWNNAME =0x80020006L;
|
||
// MessageId: DISP_E_NONAMEDARGS
|
||
// MessageText:
|
||
// No named arguments.
|
||
static const DISP_E_NONAMEDARGS =0x80020007L;
|
||
// MessageId: DISP_E_BADVARTYPE
|
||
// MessageText:
|
||
// Bad variable type.
|
||
static const DISP_E_BADVARTYPE =0x80020008L;
|
||
// MessageId: DISP_E_EXCEPTION
|
||
// MessageText:
|
||
// Exception occurred.
|
||
static const DISP_E_EXCEPTION =0x80020009L;
|
||
// MessageId: DISP_E_OVERFLOW
|
||
// MessageText:
|
||
// Out of present range.
|
||
static const DISP_E_OVERFLOW =0x8002000AL;
|
||
// MessageId: DISP_E_BADINDEX
|
||
// MessageText:
|
||
// Invalid index.
|
||
static const DISP_E_BADINDEX =0x8002000BL;
|
||
// MessageId: DISP_E_UNKNOWNLCID
|
||
// MessageText:
|
||
static const DISP_E_UNKNOWNLCID =0x8002000CL;
|
||
// MessageId: DISP_E_ARRAYISLOCKED
|
||
// Memory is locked.
|
||
static const DISP_E_ARRAYISLOCKED =0x8002000DL;
|
||
// MessageId: DISP_E_BADPARAMCOUNT
|
||
// MessageText:
|
||
// Invalid number of parameters.
|
||
static const DISP_E_BADPARAMCOUNT =0x8002000EL;
|
||
// MessageId: DISP_E_PARAMNOTOPTIONAL
|
||
// MessageText:
|
||
// Parameter not optional.
|
||
static const DISP_E_PARAMNOTOPTIONAL =0x8002000FL;
|
||
// MessageId: DISP_E_BADCALLEE
|
||
// MessageText:
|
||
// Invalid callee.
|
||
static const DISP_E_BADCALLEE =0x80020010L;
|
||
// MessageId: DISP_E_NOTACOLLECTION
|
||
// MessageText:
|
||
// Does not support a collection.
|
||
static const DISP_E_NOTACOLLECTION =0x80020011L;
|
||
// MessageId: DISP_E_DIVBYZERO
|
||
// MessageText:
|
||
// Division by zero.
|
||
static const DISP_E_DIVBYZERO =0x80020012L;
|
||
// MessageId: DISP_E_BUFFERTOOSMALL
|
||
// MessageText:
|
||
// Buffer too small
|
||
static const DISP_E_BUFFERTOOSMALL =0x80020013L;
|
||
end
|
||
type tcom_const = class(tagTYPEKIND,tagDESCKIND,tagTYPEFLAGS,
|
||
tagFUNCFLAGS,tagVARFLAGS,
|
||
tagFUNCKIND,tagCALLCONV,tagINVOKEKIND,DISPID_TYPE,tagVARKIND,
|
||
tagvtype,tagwinerr,FACILITY_DISPATCH)
|
||
//////
|
||
///////////////////////////
|
||
static const IMPLTYPEFLAG_FDEFAULT = 1;
|
||
static const IMPLTYPEFLAG_FSOURCE = 2;
|
||
static const IMPLTYPEFLAG_FRESTRICTED = 4;
|
||
static const IMPLTYPEFLAG_FDEFAULTVTABLE = 8;
|
||
////////////////////////////////
|
||
////////////////
|
||
static const DISPATCH_METHOD = 0x1;
|
||
static const DISPATCH_PROPERTYGET = 0x2;
|
||
static const DISPATCH_PROPERTYPUT = 0x4;
|
||
static const DISPATCH_PROPERTYPUTREF = 0x8;
|
||
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 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
|
||
function get_global_params();
|
||
begin
|
||
return static createvariants();
|
||
end
|
||
function createvariants();
|
||
begin
|
||
m := get_mem_mgr();
|
||
o := new tagELEMDESC(10245);//构造空的
|
||
sz := o._size_();
|
||
r := m.tmalloc(128*sz);
|
||
for i:= 0 to 126 do
|
||
begin
|
||
ptri := int64(r+i*sz);
|
||
o._setcptr_(ptri);
|
||
o.tdesc.vt := 12;
|
||
end
|
||
return r;
|
||
end
|
||
type tcom_stc_base = class(tslcstructureobj,tcom_const)
|
||
function create(stc,ptr);
|
||
begin
|
||
class(tslcstructureobj).create(stc,ptr);
|
||
end
|
||
|
||
end
|
||
type tagFUNCDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(FUNCDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function FUNCDESC_stc();
|
||
begin
|
||
return array(
|
||
("memid","int",0),
|
||
("lprgscode","intptr",0), //SCODE *
|
||
("lprgelemdescParam","intptr",0), //ELEMDESC *
|
||
("funckind","int",3),
|
||
("invkind","int",1),
|
||
("callconv","int",1),
|
||
("cParams","short",0),
|
||
("cParamsOpt","short",0),
|
||
("oVft","short",0),
|
||
("cScodes","short",1),
|
||
("elemdescFunc","user",class(tagELEMDESC).ELEMDESC_stc()),
|
||
("wFuncFlags","short",0x4)
|
||
);
|
||
end
|
||
end
|
||
type tagSAFEARRAYBOUND = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(SAFEARRAYBOUND_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function SAFEARRAYBOUND_stc();
|
||
begin
|
||
return array(
|
||
("cElements","int",0),
|
||
("lLbound","int",0)
|
||
);
|
||
end
|
||
property cElements index "cElements" read _getvalue_ write _setvalue_;
|
||
property lLbound index "lLbound" read _getvalue_ write _setvalue_;
|
||
end
|
||
type tagTYPEDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(TYPEDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function TYPEDESC_stc();
|
||
begin
|
||
return array(
|
||
("DUMMYUNIONNAME","intptr",0),
|
||
("vt","short",12)
|
||
);
|
||
end
|
||
public
|
||
property lptdesc index "DUMMYUNIONNAME" read _getvalue_;
|
||
property lpadesc index "DUMMYUNIONNAME" read _getvalue_;
|
||
property hreftype read gethreftype;
|
||
property vt index "vt" read _getvalue_ write _setvalue_;
|
||
private
|
||
function gethreftype();
|
||
begin
|
||
return mtool().readint(_getvalueaddr_("DUMMYUNIONNAME"));
|
||
end
|
||
end
|
||
type tagARRAYDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(ARRAYDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function ARRAYDESC_stc();
|
||
begin
|
||
return array(
|
||
("tdescElem","user",class(tagTYPEDESC).TYPEDESC_stc()),
|
||
("cDims","short",0) ,
|
||
("rgbounds","user",class(tagSAFEARRAYBOUND).SAFEARRAYBOUND_stc())
|
||
);
|
||
end
|
||
property tdescElem read get_valueas_TYPEDESC;
|
||
property rgbounds read get_valueas_SAFEARRAYBOUND;
|
||
private
|
||
function get_valueas_TYPEDESC();
|
||
begin
|
||
return new tagTYPEDESC(_getvalueaddr2_("tdescElem"));
|
||
end
|
||
function get_valueas_SAFEARRAYBOUND();
|
||
begin
|
||
return new tagSAFEARRAYBOUND(_getvalueaddr2_("rgbounds"));
|
||
end
|
||
end
|
||
|
||
type tagVARDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct :=static MemoryAlignmentCalculate(VARDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function VARDESC_stc();
|
||
begin
|
||
return array(
|
||
("memid","int",0),
|
||
("lpstrSchema","intptr",0), //string
|
||
("DUMMYUNIONNAME","intptr",0),
|
||
("elemdescVar","user",class(tagELEMDESC).ELEMDESC_stc()) ,
|
||
("wVarFlags","short",1) ,
|
||
("varkind","int",0)
|
||
);
|
||
end
|
||
end
|
||
|
||
type tagPARAMDESCEX = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(PARAMDESCEX_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function PARAMDESCEX_stc();
|
||
begin
|
||
return array(
|
||
("cBytes","int",0),
|
||
("varDefaultValue","user",class(tagVARIANT).variant_stc())
|
||
);
|
||
end
|
||
property cBytes index "cBytes" read _getvalue_ write _setvalue_;
|
||
private
|
||
function get_varDefaultValue();
|
||
begin
|
||
ptr := _getvalueaddr2_("varDefaultValue");
|
||
if ptr=0 then return ;
|
||
return new tagVARIANT(ptr);
|
||
end
|
||
end
|
||
type tagIDLDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(IDLDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function IDLDESC_stc();
|
||
begin
|
||
return array(
|
||
("dwReserved","intptr",0),
|
||
("wIDLFlags","short",0)
|
||
);
|
||
end
|
||
property wIDLFlags index "wIDLFlags" read _getvalue_ write _setvalue_;
|
||
end
|
||
type tagPARAMDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(PARAMDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function PARAMDESC_stc();
|
||
begin
|
||
return array(
|
||
("pparamdescex","intptr",0),
|
||
("wParamFlags","short",0)
|
||
);
|
||
end
|
||
property pparamdescex read get_pparamdescex;
|
||
property wParamFlags index "wParamFlags" read _getvalue_ write _setvalue_;
|
||
private
|
||
function get_pparamdescex();
|
||
begin
|
||
ptr := _getvalue_("pparamdescex");
|
||
if ptr then return new tagPARAMDESCEX(ptr);
|
||
end
|
||
end
|
||
|
||
type tagELEMDESC = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(ELEMDESC_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function ELEMDESC_stc();
|
||
begin
|
||
return array(
|
||
("tdesc","user",class(tagTYPEDESC).TYPEDESC_stc()),
|
||
("DUMMYUNIONNAME","user",class(tagIDLDESC).IDLDESC_stc())
|
||
);
|
||
end
|
||
property tdesc read get_tdesc;
|
||
property DUMMYUNIONNAME read get_DUMMYUNIONNAME;
|
||
private
|
||
function get_tdesc();
|
||
begin
|
||
return new tagTYPEDESC(_getvalueaddr2_("tdesc"));
|
||
end
|
||
function get_DUMMYUNIONNAME();
|
||
begin
|
||
return new tagIDLDESC(_getvalueaddr2_("DUMMYUNIONNAME"));
|
||
end
|
||
|
||
end
|
||
type tagEXCEPINFO = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(EXCEPINFO_stc());
|
||
inherited create(struct,ptr);
|
||
end
|
||
class function EXCEPINFO_stc();
|
||
begin
|
||
return array(
|
||
("wCode","short",1001),
|
||
("wReserved","short",0) ,
|
||
("bstrSource","intptr",0) ,
|
||
("bstrDescription","intptr",0) ,
|
||
("bstrHelpFile","intptr",0) ,
|
||
("dwHelpContext","int",0) ,
|
||
("pvReserved","intptr",0),
|
||
("DeferredFillIn","intptr",0) ,
|
||
("SCODE","intptr",0)
|
||
);
|
||
end
|
||
property wCode index "wCode" read _getvalue_ write _setvalue_;
|
||
property bstrSource index "bstrSource" read _getvalue_ write _setvalue_;
|
||
property bstrDescription index "bstrDescription" read _getvalue_ write _setvalue_;
|
||
end
|
||
type tagTYPEATTR = class(tcom_stc_base)
|
||
function create(ptr);
|
||
begin
|
||
struct := static MemoryAlignmentCalculate(TYPEATTR_stc());
|
||
inherited create(struct,ptr);
|
||
//_setvalue_("cbSizeInstance",_size_());
|
||
end
|
||
class function TYPEATTR_stc();
|
||
begin
|
||
return array(
|
||
("guid","user",get_guid_stc()), //类型信息的 GUID。
|
||
("lcid","int",0), //成员名称和文档字符串的区域设置。
|
||
("dwReserved","int",0),
|
||
("memidConstructor","int",0),
|
||
("memidDestructor","int",0),
|
||
("lpstrSchema","intptr",0),
|
||
("cbSizeInstance","int",0), //此类型的实例的大小。
|
||
("typekind","int",4), //TYPEKIND 值描述此信息所描述的类型。//TKIND_DISPATCH
|
||
("cFuncs","short",1), //指示此结构描述的接口上的函数数目。
|
||
("cVars","short",0), //指示此结构所描述的接口上的变量和数据字段的数目。
|
||
("cImplTypes","short",0), //指示此结构描述的接口上实现的接口的数量。
|
||
("cbSizeVft","short",0), // 此类型的虚拟方法表 (VTBL) 的大小。
|
||
("cbAlignment","short",8), //指定此类型实例的字节对齐方式。
|
||
("wTypeFlags","short",TYPEFLAG_FDISPATCHABLE), //tagTYPEFLAGS
|
||
("wMajorVerNum","short",0),
|
||
("wMinorVerNum","short",0),
|
||
("tdescAlias","user",class(tagTYPEDESC).TYPEDESC_stc),
|
||
("idldescType","user",class(tagIDLDESC).IDLDESC_stc)
|
||
);
|
||
end
|
||
public
|
||
property cFuncs index "cFuncs" read _getvalue_ write _setvalue_;
|
||
function guidobj();
|
||
begin
|
||
ptr := _getvalueaddr2_("guid");
|
||
if not fguidobj then
|
||
begin
|
||
fguidobj := new tclsguid(ptr);
|
||
end
|
||
fguidobj._setcptr_(ptr);
|
||
return fguidobj;
|
||
end
|
||
private
|
||
fguidobj;
|
||
end
|
||
|
||
type tagVARIANT =class(tcom_stc_base)
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
stc := static MemoryAlignmentCalculate(variant_stc());
|
||
inherited create(stc,ptr);
|
||
if not fmtool then
|
||
fmtool := get_mem_mgr();
|
||
end
|
||
class function variant_stc();
|
||
begin
|
||
return array(
|
||
("vt","short",0),
|
||
("wReserved1","short",0),
|
||
("wReserved2","short",0),
|
||
("wReserved3","short",0),
|
||
("data","intptr",0),
|
||
("data2","intptr",0)
|
||
);
|
||
end
|
||
property llVal index "data" read _getvalue_ write _setvalue_;
|
||
private
|
||
function getdataaddr(); //获取地址
|
||
begin
|
||
return _getvalueaddr_("data");
|
||
end
|
||
static fmtool;
|
||
end
|
||
type tagDISPPARAMS = class(tcom_stc_base)
|
||
class function DISPPARAMS_Stc();
|
||
begin
|
||
return array(
|
||
("rgvarg","intptr",0),
|
||
("rgdispidNamedArgs","intptr",0),
|
||
("cArgs","int",0),
|
||
("cNamedArgs","int",0)
|
||
);
|
||
end
|
||
function create(ptr)
|
||
begin
|
||
stc := static MemoryAlignmentCalculate(DISPPARAMS_Stc());
|
||
inherited create(stc,ptr);
|
||
end
|
||
function getcnameargs();
|
||
begin
|
||
ct := _getvalue_("cNamedArgs");
|
||
r := array();
|
||
if ct>0 then
|
||
begin
|
||
p := _getvalue_("rgdispidNamedArgs");
|
||
r := mtool().readints(p,ct);
|
||
end
|
||
return r;
|
||
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)
|
||
public
|
||
function create(ptr)
|
||
begin
|
||
stc := static MemoryAlignmentCalculate(array(
|
||
("ptr","intptr",0)
|
||
)
|
||
);
|
||
inherited create(stc,ptr);
|
||
end
|
||
function ansistr(idx);
|
||
begin
|
||
if idx>0 then
|
||
begin
|
||
p := mtool().readptr( int64(_getptr_()+idx*8));
|
||
end else
|
||
p := _getvalue_("ptr");
|
||
return wideptrtoansi(p);
|
||
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 mypointptr = class(tslcstructureobj)
|
||
private
|
||
static SSTRUCT;
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then
|
||
begin
|
||
SSTRUCT := MemoryAlignmentCalculate(array(
|
||
(0,"intptr",0)
|
||
)
|
||
);
|
||
end
|
||
return SSTRUCT;
|
||
end
|
||
public
|
||
function create(ptr);
|
||
begin
|
||
inherited create(getstruct(),ptr);
|
||
end
|
||
end
|
||
type myintptr = class(tslcstructureobj)
|
||
private
|
||
static SSTRUCT;
|
||
class function getstruct()
|
||
begin
|
||
if not SSTRUCT then
|
||
begin
|
||
SSTRUCT := MemoryAlignmentCalculate(array(
|
||
(0,"int",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_com(thisfunction(QueryInterface)));
|
||
fvtable._setvalue_("Release",makeinstance_com(thisfunction(Release)));
|
||
fvtable._setvalue_("AddRef",makeinstance_com(thisfunction(addref)));
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
|
||
begin
|
||
ppv := 0;
|
||
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
|
||
function _getvtableptr_();
|
||
begin
|
||
return fvtable._getptr_();
|
||
end
|
||
end
|
||
function get_func_id_str(id);
|
||
begin
|
||
global g_id_name_cache;
|
||
if not g_id_name_cache then g_id_name_cache := new func_mid_cache();
|
||
return g_id_name_cache.get_id_str(id);
|
||
end
|
||
function get_func_str_id(s);
|
||
begin
|
||
global g_id_name_cache;
|
||
if not g_id_name_cache then g_id_name_cache := new func_mid_cache();
|
||
return g_id_name_cache.get_str_id(s);
|
||
end
|
||
type func_mid_cache = class
|
||
function create();
|
||
begin
|
||
frgDispIds := array("":0);
|
||
frgDispIds2 := array();
|
||
end
|
||
function get_str_id(s);
|
||
begin
|
||
id := frgDispIds[s];
|
||
if id>0 then
|
||
begin
|
||
return id;
|
||
end
|
||
id := length(frgDispIds);
|
||
frgDispIds2[id] := s;
|
||
frgDispIds[s] := id;
|
||
return id;
|
||
end
|
||
function get_id_str(id);
|
||
begin
|
||
return frgDispIds2[id];
|
||
end
|
||
private
|
||
frgDispIds;
|
||
frgDispIds2;
|
||
end
|
||
function Invoke_test(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer;
|
||
pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;
|
||
begin
|
||
echo "\r\n>>>>>>idispatch>>>>>>:",functionname(1)," ",dispIdMember," ",wFlags," ",pVarResult," err:",pExcepInfo;
|
||
end
|
||
type idispatch=class(iunkown)
|
||
protected
|
||
static IID_IDispatch;
|
||
ftypeinfo;
|
||
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_com(thisfunction(GetTypeInfoCount)));
|
||
fvtable._setvalue_("GetTypeInfo",makeinstance_com(thisfunction(GetTypeInfo)));
|
||
fvtable._setvalue_("GetIDsOfNames",makeinstance_com(thisfunction(GetIDsOfNames)));
|
||
fvtable._setvalue_("Invoke",makeinstance_com(thisfunction(Invoke_)));
|
||
//echo tostn(fvtable._getdata_);
|
||
end
|
||
fglobalL := TS_GetGlobalL();
|
||
end
|
||
function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n>>>>>>idispatch:",functionname(1);
|
||
return E_NOTIMPL;
|
||
pctinfo := 0;
|
||
ns := fcom_mgr.method_names();
|
||
if ifarray(ns) and ns then
|
||
begin
|
||
pctinfo := 1;
|
||
for i,v in ns do
|
||
begin
|
||
get_func_str_id(lowercase(v));
|
||
end
|
||
return S_OK;
|
||
end
|
||
return E_NOTIMPL;
|
||
//return E_NOTIMPL;
|
||
return 1;
|
||
//return E_NOTIMPL S_OK
|
||
end
|
||
function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n>>>>>>idispatch:",functionname(1),iTInfo," ",lcid," ",ppTInfo;
|
||
ppTInfo := 0;
|
||
return E_NOTIMPL;
|
||
if not fcom_mgr.method_names() then return E_NOTIMPL;
|
||
if not ftypeinfo then
|
||
begin
|
||
ftypeinfo := new ITypeInfo();
|
||
ftypeinfo.fcom_mgr := fcom_mgr;
|
||
end
|
||
ppTInfo := ftypeinfo._getptr_();
|
||
return S_OK;
|
||
//return S_OK, DISP_E_BADINDEX
|
||
end
|
||
function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n>>>>>>idispatch:",functionname(1)," ",riid," ",lcid," ",cNames;
|
||
//return E_NOTIMPL;
|
||
if cnames>1 then return E_INVALIDARG;
|
||
ostr := new tptrarray(rgszNames);
|
||
rgDispId := get_func_str_id(ostr.ansistr());
|
||
return S_OK;
|
||
//E_OUTOFMEMORY DISP_E_UNKNOWNNAME DISP_E_UNKNOWNLCID
|
||
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
|
||
echo "\r\n>>>>>>idispatch:",functionname(1)," ",dispIdMember," ",wFlags," ",pVarResult," err:",pExcepInfo;
|
||
fname := get_func_id_str(dispIdMember);
|
||
if wFlags=2 then
|
||
begin
|
||
FInvokename := fname;
|
||
if pVarResult then
|
||
begin
|
||
rv := new tagVARIANT( pVarResult);
|
||
rv._setvalue_("vt" , VT_DISPATCH);
|
||
rv._setvalue_("data",s);
|
||
end
|
||
return S_OK;
|
||
end
|
||
if wFlags .& 1 then
|
||
begin
|
||
if ifnil(fname) then fname := FInvokename;
|
||
FInvokename := nil;
|
||
pms := trans_params(pDispParams);
|
||
x := fcom_mgr.invoke_call(fname,pms);
|
||
if pVarResult then ObjToVariantRef(fglobalL,x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
|
||
return S_OK;
|
||
end else
|
||
if (wFlags .& 4) or (wFlags .& 8) then
|
||
begin
|
||
fcom_mgr.invoke_propertyset(fname,trans_params(pDispParams)[0]);
|
||
end
|
||
return S_OK;
|
||
//////////////返回很多错误类型//////
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
|
||
begin
|
||
ppv := 0;
|
||
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
|
||
begin
|
||
fcom_mgr.stop_run();
|
||
end
|
||
return r;
|
||
end
|
||
function AddRef(s:pointer):integer;stdcall;virtual;
|
||
begin
|
||
r := inherited;
|
||
return r;
|
||
end
|
||
private
|
||
function trans_params(pDispParams);
|
||
begin
|
||
o := new tagDISPPARAMS(pDispParams);
|
||
//echo "\r\ncnamecout:",tostn(o.getcnameargs());
|
||
pp := o.getArgs();
|
||
pms := array();
|
||
for idx,p1 in pp do
|
||
begin
|
||
VariantToObj2(fglobalL,p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
|
||
pms[idx] := r;
|
||
end
|
||
return pms;
|
||
end
|
||
private
|
||
FInvokename;
|
||
fglobalL;
|
||
end
|
||
type ITypeInfo=class(iunkown)
|
||
protected
|
||
static IID_ITypeInfo;
|
||
function createvtb(ptr);override;
|
||
begin
|
||
return new ITypeInfoVtbl(ptr);
|
||
end
|
||
public
|
||
[weakref] fcom_mgr;
|
||
function create(ptr)
|
||
begin
|
||
nptr := not ptr;
|
||
inherited ;
|
||
if not IID_ITypeInfo then
|
||
begin
|
||
IID_ITypeInfo := new tguid();
|
||
IID_ITypeInfo.readstr("{00020401-0000-0000-C000-000000000046}");
|
||
end
|
||
if nptr then
|
||
begin
|
||
//echo tostn(fvtable._getdata_());
|
||
fvtable._setvalue_("GetTypeAttr",makeinstance_com(thisfunction(GetTypeAttr)));
|
||
fvtable._setvalue_("GetTypeComp",makeinstance_com(thisfunction(GetTypeComp)));
|
||
fvtable._setvalue_("GetFuncDesc",makeinstance_com(thisfunction(GetFuncDesc)));
|
||
fvtable._setvalue_("GetVarDesc",makeinstance_com(thisfunction(GetVarDesc)));
|
||
fvtable._setvalue_("GetNames",makeinstance_com(thisfunction(GetNames)));
|
||
fvtable._setvalue_("GetRefTypeOfImplType",makeinstance_com(thisfunction(GetRefTypeOfImplType)));
|
||
fvtable._setvalue_("GetImplTypeFlags",makeinstance_com(thisfunction(GetImplTypeFlags)));
|
||
fvtable._setvalue_("GetIDsOfNames",makeinstance_com(thisfunction(GetIDsOfNames)));
|
||
fvtable._setvalue_("Invoke",makeinstance_com(thisfunction(Invoke_)));
|
||
fvtable._setvalue_("GetDocumentation",makeinstance_com(thisfunction(GetDocumentation)));
|
||
fvtable._setvalue_("GetDllEntry",makeinstance_com(thisfunction(GetDllEntry)));
|
||
fvtable._setvalue_("GetRefTypeInfo",makeinstance_com(thisfunction(GetRefTypeInfo)));
|
||
fvtable._setvalue_("AddressOfMember",makeinstance_com(thisfunction(AddressOfMember)));
|
||
fvtable._setvalue_("CreateInstance",makeinstance_com(thisfunction(CreateInstance)));
|
||
fvtable._setvalue_("GetMops",makeinstance_com(thisfunction(GetMops)));
|
||
fvtable._setvalue_("GetContainingTypeLib",makeinstance_com(thisfunction(GetContainingTypeLib)));
|
||
fvtable._setvalue_("ReleaseTypeAttr",makeinstance_com(thisfunction(ReleaseTypeAttr)));
|
||
fvtable._setvalue_("ReleaseFuncDesc",makeinstance_com(thisfunction(ReleaseFuncDesc)));
|
||
fvtable._setvalue_("ReleaseVarDesc",makeinstance_com(thisfunction(ReleaseVarDesc)));
|
||
//echo tostn(fvtable._getdata_());
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
|
||
begin
|
||
ppv := 0;
|
||
if IID_IUnknown.equ(riid) or IID_ITypeInfo.equ(riid) then
|
||
begin
|
||
ppv := _getptr_();
|
||
AddRef(ppv);
|
||
return 0;
|
||
end
|
||
return E_NOINTERFACE;
|
||
end
|
||
function AddRef(s:pointer):integer;stdcall;virtual;
|
||
begin
|
||
r := inherited;
|
||
//echo "\r\n%%%%%%%%%ref add:",r," ",s;
|
||
return r;
|
||
end
|
||
function Release(s:pointer):integer;stdcall;virtual;
|
||
begin
|
||
r := inherited;
|
||
//echo "\r\n%%%%%%%%%ref release:",r," ",s;
|
||
return r;
|
||
end
|
||
function GetTypeAttr(sf:pointer;var pptypeattr:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1)," ",sf," ",pptypeattr;
|
||
//return E_NOTIMPL;
|
||
if ifnil(ftypeattr) then
|
||
begin
|
||
ftypeattr := new tagTYPEATTR();
|
||
ftypeattr.guidobj().readstr(fcom_mgr.get_clsid());
|
||
ns := fcom_mgr.method_names();
|
||
if ifarray(ns) then ftypeattr.cFuncs := length(ns) ;
|
||
end
|
||
pptypeattr := ftypeattr._getptr_();
|
||
return S_OK;
|
||
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
|
||
end
|
||
function GetTypeComp(sf:pointer;var ppTComp:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1)," + ",sf ;
|
||
if not fITypecomp then
|
||
begin
|
||
fITypecomp := new ITypecomp();
|
||
fITypecomp.fitypeinfo := sf;
|
||
end
|
||
ppTComp := fITypecomp._getptr_();
|
||
return S_OK;
|
||
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
|
||
end
|
||
function GetFuncDesc(sf:pointer;idx:integer;var ppFuncDesc:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1)," ",idx," ",ppFuncDesc;
|
||
//return E_NOTIMPL;
|
||
if not fFuncDesc then fFuncDesc := get_funcs_info();
|
||
fFuncDesc._setvalue_("memid",idx+1);
|
||
ppFuncDesc := fFuncDesc._getptr_();
|
||
return S_OK;
|
||
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
|
||
end
|
||
fFuncDesc;
|
||
function GetVarDesc(sf:pointer;index:integer;var ppVarDesc:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
|
||
end
|
||
function GetNames(sf:pointer;memid:integer;var rgBstrNames:pointer;cMaxNames:integer;var pcNames:integer):integer;stdcall;virtual; //处理命名参数问题
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1)," ",memid," ",rgBstrNames," ",cMaxNames," ",pcNames;
|
||
return E_NOTIMPL;
|
||
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
|
||
end
|
||
function GetRefTypeOfImplType(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
end
|
||
function GetImplTypeFlags(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
end
|
||
function GetIDsOfNames(sf:pointer;rgszNames:pointer;var MemId:integer;):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
end
|
||
function Invoke_(s:pointer;pvInstance:pointer;memid:integer;wFlags:short;pDispParams:pointer;
|
||
pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
//return DISP_E_EXCEPTION E_INVALIDARG S_OK;
|
||
end
|
||
function GetDocumentation(s:pointer;memid:integer; var pBstrName:pointer; var pBstrDocString:pointer; var pdwHelpContext:integer; var pBstrHelpFile:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
pBstrName := 0;
|
||
pBstrDocString := 0;
|
||
pdwHelpContext := 0;
|
||
pBstrHelpFile := 0;
|
||
//pBstrName := pBstrDocString := pdwHelpContext := pBstrHelpFile := 0 ;
|
||
return S_OK;
|
||
return E_NOTIMPL;
|
||
end
|
||
function GetDllEntry(s:pointer;memid:integer;invkind:integer;var pbstrdllname:pointer;var pbstrname:pointer;var pwordinal:short):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
pbstrdllname := 0;
|
||
pbstrname := 0;
|
||
pwordinal := 0;
|
||
return S_OK;
|
||
//return E_INVALIDARG,E_OUTOFMEMORY;
|
||
end
|
||
function GetRefTypeInfo(sf:pointer;hRefType:integer;var ITypeInfo:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
end
|
||
function AddressOfMember(sf:pointer;memid:integer;invKind:integer;var ppv:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOTIMPL;
|
||
//return S_OK;
|
||
end
|
||
function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;//
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
return E_NOINTERFACE;
|
||
end
|
||
function GetMops(sf:pointer;memid:integer;var pBstrMops:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
pBstrMops := 0;
|
||
return S_OK;
|
||
end
|
||
function GetContainingTypeLib(sf:pointer;var ppTLib:pointer;var pIndex:integer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
ppTLib := 0;ppTLib := -1;
|
||
return E_NOINTERFACE;
|
||
return E_NOTIMPL;
|
||
end
|
||
procedure ReleaseTypeAttr(sf:pointer;pTypeAttr:pointer);stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1)," ",sf;
|
||
//pTypeAttr := 0;
|
||
end
|
||
procedure ReleaseFuncDesc(sf:pointer;pFuncDesc:pointer);stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
//pFuncDesc := 0;
|
||
end
|
||
procedure ReleaseVarDesc(sf:pointer;pVarDesc:pointer);stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypeInfo:",functionname(1);
|
||
end
|
||
private
|
||
ftypeattr;
|
||
fITypecomp;
|
||
end
|
||
function get_funcs_info();
|
||
begin
|
||
r := new tagFUNCDESC();
|
||
r._setvalue_("lprgelemdescParam",get_global_params());
|
||
r._setvalue_("cParams",0);
|
||
return r;
|
||
end
|
||
type ITypecomp=class(iunkown)
|
||
protected
|
||
static IID_ITypeComp;
|
||
function createvtb(ptr);override;
|
||
begin
|
||
return new ITypecompVtbl(ptr);
|
||
end
|
||
public
|
||
[weakref] fcom_mgr;
|
||
function create(ptr)
|
||
begin
|
||
nptr := not ptr;
|
||
inherited ;
|
||
if not IID_ITypeComp then
|
||
begin
|
||
IID_ITypeComp := new tguid();
|
||
IID_ITypeComp.readstr("{00020403-0000-0000-C000-000000000046}");
|
||
end
|
||
if nptr then
|
||
begin
|
||
//echo tostn(fvtable._getdata_());
|
||
fvtable._setvalue_("Bind",makeinstance_com(thisfunction(Bind)));
|
||
fvtable._setvalue_("BindType",makeinstance_com(thisfunction(BindType)));
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
|
||
begin
|
||
ppv := 0;
|
||
if IID_IUnknown.equ(riid) or IID_ITypeComp.equ(riid) then
|
||
begin
|
||
ppv := _getptr_();
|
||
AddRef(ppv);
|
||
return 0;
|
||
end
|
||
return E_NOINTERFACE;
|
||
end
|
||
function AddRef(s:pointer):integer;stdcall;override;
|
||
begin
|
||
r := inherited;
|
||
//echo "\r\n%%%%%%%%%comp ref add:",r," ",s;
|
||
return r;
|
||
end
|
||
function Release(s:pointer):integer;stdcall;override;
|
||
begin
|
||
r := inherited;
|
||
//echo "\r\n%%%%%%%%%comp ref release:",r," ",s;
|
||
return r;
|
||
end
|
||
function Bind(sf:pointer;szName:widestring;lHashVal:integer;wFlags:short;var ppTInfo:pointer; var pDescKind:integer; var pBindPtr:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypecomp:",functionname(1)," ",tostn(params);
|
||
return E_NOTIMPL;
|
||
//pDescKind := DESCKIND_MAX;
|
||
|
||
case wFlags of
|
||
DISPATCH_METHOD:
|
||
begin
|
||
|
||
end
|
||
DISPATCH_PROPERTYGET:
|
||
begin
|
||
|
||
end
|
||
DISPATCH_PROPERTYPUT:
|
||
begin
|
||
|
||
end
|
||
DISPATCH_PROPERTYPUTREF:
|
||
begin
|
||
|
||
end
|
||
|
||
end;
|
||
pDescKind := DESCKIND_TYPECOMP;
|
||
return S_OK;
|
||
return E_INVALIDARG;
|
||
if wFlags .& 1 then
|
||
begin
|
||
ppTInfo := fitypeinfo;
|
||
pDescKind := DESCKIND_FUNCDESC;//DESCKIND_VARDESC;
|
||
if not fFuncDesc then
|
||
begin
|
||
fFuncDesc := get_funcs_info();
|
||
end
|
||
fFuncDesc._setvalue_("memid",get_func_str_id(string(szName)));
|
||
//if not fFuncDesc then fFuncDesc := new tagFUNCDESC();
|
||
pBindPtr := fFuncDesc._getptr_();//fFuncDesc._getptr_();
|
||
return S_OK;
|
||
end
|
||
return E_NOTIMPL;
|
||
end
|
||
function BindType(sf:pointer;szName:widestring;lHashVal:integer;var ppTInfo:pointer;var ppTComp:pointer):integer;stdcall;virtual;
|
||
begin
|
||
echo "\r\n===ITypecomp:",functionname(1)," ",szName;
|
||
//return E_NOTIMPL;
|
||
end
|
||
fitypeinfo;
|
||
fFuncDesc;
|
||
fvardesc;
|
||
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_com(thisfunction(CreateInstance)));
|
||
fvtable._setvalue_("LockServer",makeinstance_com(thisfunction(LockServer)));
|
||
end
|
||
end
|
||
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
|
||
begin
|
||
ppv := 0;
|
||
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 get_guid_stc();
|
||
begin
|
||
return array(
|
||
("data1","int",0),
|
||
("data2","short",0),
|
||
("data3","short",0),
|
||
("data4","byte[8]",array(0, 0, 0, 0, 0, 0, 0, 0)),
|
||
);
|
||
end
|
||
|
||
function wideptrtoansi(p);
|
||
begin
|
||
if not p then return "";
|
||
r := wideptr_to_ansi(p);
|
||
return r;
|
||
wlen := uaw_wcslen(p);
|
||
sansi := "";
|
||
if wlen>0 then
|
||
begin
|
||
setlength(sansi,wlen*2+1);
|
||
WideCharToMultiByte(0,0,p,wlen,sansi,length(sansi),0,0);
|
||
for i:= 1 to wlen*2+1 do
|
||
begin
|
||
if sansi[i]="\0" then return sansi[1:(i-1)];
|
||
end
|
||
end
|
||
return sansi;
|
||
end
|
||
function wideptr_to_ansi(s);
|
||
begin
|
||
_f_ := static function(s:pointer):string;cdecl;external makeinstance_com(thisfunction(wideptr_to_ansi_i));
|
||
k := call(_f_,s);
|
||
return k;
|
||
end
|
||
function wideptr_to_ansi_i( s:widestring):pointer;
|
||
begin
|
||
global g_wideptr_to_ansi_i_return;
|
||
g_wideptr_to_ansi_i_return := string(s);
|
||
return get_tsl_mem_ptr(g_wideptr_to_ansi_i_return);
|
||
end
|
||
function gbk_to_wideptr(s,wsowner);
|
||
begin
|
||
wsowner := widestring(s);
|
||
return get_tsl_mem_ptr(wsowner);
|
||
end
|
||
function makeinstance_com(f); //构造指针
|
||
begin
|
||
global g_func_handles;
|
||
if not ifarray(g_func_handles) then g_func_handles := array();
|
||
idx := inttostr( int64(f));
|
||
if g_func_handles[idx] then return g_func_handles[idx];
|
||
//r := makeinstance(makeweakref(f));
|
||
r := makeinstance(f);
|
||
g_func_handles[idx] := r;
|
||
return r;
|
||
end
|
||
function destroy_instance() //销毁指针
|
||
begin
|
||
global g_func_handles;
|
||
for i,v in g_func_handles do deleteinstance(v);
|
||
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(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;lpWideCharStr:pointer;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar";
|
||
function LoadRegTypeLib(rguid:pointer; wVerMajor:short; wVerMinor:short;lcid:integer;var pptlib:pointer):pointer;cdecl;external "Oleaut32.dll" name "LoadRegTypeLib";
|
||
function CoTaskMemAlloc(cb:pointer):pointer;stdcall;external "Ole32.dll" name "CoTaskMemAlloc";
|
||
function CoTaskMemRealloc(pv:pointer;cb:pointer):pointer;stdcall;external "Ole32.dll" name "CoTaskMemRealloc";
|
||
procedure CoTaskMemFree(cb:pointer);stdcall;external "Ole32.dll" name "CoTaskMemFree";
|
||
initialization
|
||
destroy_instance();
|
||
end. |