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(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  
        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(thisfunction(GetTypeInfoCount)));           
            fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo))); 
            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));            
            fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));   
            //echo tostn(fvtable._getdata_);                             
        end 
        fglobalL := TS_GetGlobalL();
    end    
    function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
    begin 
        return  E_NOTIMPL;
        echo "\r\n>>>>>>idispatch:",functionname(1);        
        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(thisfunction(GetTypeAttr)));           
            fvtable._setvalue_("GetTypeComp",makeinstance(thisfunction(GetTypeComp)));           
            fvtable._setvalue_("GetFuncDesc",makeinstance(thisfunction(GetFuncDesc)));           
            fvtable._setvalue_("GetVarDesc",makeinstance(thisfunction(GetVarDesc)));           
            fvtable._setvalue_("GetNames",makeinstance(thisfunction(GetNames)));           
            fvtable._setvalue_("GetRefTypeOfImplType",makeinstance(thisfunction(GetRefTypeOfImplType)));           
            fvtable._setvalue_("GetImplTypeFlags",makeinstance(thisfunction(GetImplTypeFlags)));           
            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));           
            fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));           
            fvtable._setvalue_("GetDocumentation",makeinstance(thisfunction(GetDocumentation)));           
            fvtable._setvalue_("GetDllEntry",makeinstance(thisfunction(GetDllEntry)));           
            fvtable._setvalue_("GetRefTypeInfo",makeinstance(thisfunction(GetRefTypeInfo)));           
            fvtable._setvalue_("AddressOfMember",makeinstance(thisfunction(AddressOfMember)));           
            fvtable._setvalue_("CreateInstance",makeinstance(thisfunction(CreateInstance)));           
            fvtable._setvalue_("GetMops",makeinstance(thisfunction(GetMops)));           
            fvtable._setvalue_("GetContainingTypeLib",makeinstance(thisfunction(GetContainingTypeLib)));           
            fvtable._setvalue_("ReleaseTypeAttr",makeinstance(thisfunction(ReleaseTypeAttr)));           
            fvtable._setvalue_("ReleaseFuncDesc",makeinstance(thisfunction(ReleaseFuncDesc)));           
            fvtable._setvalue_("ReleaseVarDesc",makeinstance(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(thisfunction(Bind)));           
            fvtable._setvalue_("BindType",makeinstance(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(thisfunction(CreateInstance)));
            fvtable._setvalue_("LockServer",makeinstance(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(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 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
end.