unit utslvcl_com;
interface
(*
    //20231111
    //范例    
    步骤:
    //继承 t_com_class
    //重写 get_clsid
    //重写 get_com_name
    //重写 invoke_param_is_excel
    //重写 execute_retun_is_excel
    //重写 invoke_call
    //重写 install_for_all_users
    //编译成exe
    //安装  名称.exe -install 
    //卸载  名称.exe -uninstall
    //************脚本范例,编译该脚本为exe***************************
    com := new my_com();
    return com.do_command();
    type my_com=class(t_com_class)
        uses utslvcl_com;
        function create();
        begin
            inherited;
        end 
        function get_clsid();virtual; //配置clsid
        begin
            return "{F59A8177-02A0-4019-A393-AF079F9AB365}";
        end 
        function get_com_name();virtual; //配置名称
        begin
            return "mycom.test";
        end
    end 
*)
uses  cstructurelib,tslvcl;
function sh_get_IShellLinkW(); //获取快捷方式创建接口
function create_short_cutA(targ,lnk);//创建文件快捷方式
type inukownvtb = class(tslcstructureobj)
    function create(ptr);
    begin
        struct := MemoryAlignmentCalculate(get_vtb_struct());  
        inherited create(struct,ptr);  
    end 
    protected 
    function get_vtb_struct();virtual;
    begin
        return array(
                ("QueryInterface","intptr",0),
                ("AddRef","intptr",0),
                ("Release","intptr",0)
                );
    end 
end 
type idispatchvtb =class(inukownvtb)
    public
    function create(ptr)
    begin
        inherited ;
    end
    protected 
    function get_vtb_struct();override;
    begin
        return inherited union array(
                ("GetTypeInfoCount","intptr",0),
                ("GetTypeInfo","intptr",0),
                ("GetIDsOfNames","intptr",0),
                ("Invoke","intptr",0)
                );
    end 
end 
type iClassFactoryvtb =class(inukownvtb)
    public
    function create(ptr)
    begin
        inherited ;
    end
    protected 
    function get_vtb_struct();override;
    begin
        return inherited union array(
                ("CreateInstance","intptr",0),
                ("LockServer","intptr",0)
                );
    end 
end 
type tclsguid = class(tguid) //clsid对象 
    function create(ptr);
    begin
        inherited;
    end  
end 
type t_com_class = class()
    private
    theFactory;
    dwRegister;
    sguid;
    fapp;
    public 
    function create();
    begin    
    end 
    function get_clsid();virtual; //配置clsid
    begin
        return "{F59A8177-02A0-4019-A393-AF079F9AB362}";
        //raise "clsid err";
    end 
    function get_com_name();virtual; //配置名称
    begin
        return "tscomctl.test";
        //raise "com name err";
    end
    function invoke_param_is_excel(fname);virtual; //执行时候参数是否为excel格式
    begin
        return false;
    end 
    function execute_retun_is_excel(fname);virtual;//返回时候参数是否为excel格式
    begin
        return false;
    end 
    function invoke_call(fname,pms);virtual; //执行函数
    begin
        return callinarray(findfunction(fname),pms);
    end 
    function COINIT_Param();virtual; //启动参数
    begin
        return 0;
    end 
    function install_check();virtual; //安装前检查
    begin
        return true;
    end 
    function install_for_all_users();virtual; //是否安装到本地为所有人使用
    begin
        return false;
    end     
    function stop_run(); //停止
    begin
        fapp._wapi.PostQuitMessage(0);
    end     
    function do_command();//执行
    begin
        for i:= 0 to sysparamcount() do 
        begin
            si := sysparamstr(i);
            if si="-Embedding" or si= "/Embedding" then 
            begin
                return run_com();
            end  
            if si="-install" then 
            begin
                return do_install();
            end  
            if si="-uninstall" then 
            begin
                return do_uninstall();
            end  
        end 
        //sleep(10000);
    end 
    function install_success();virtual;
    begin
        echo  "步骤：安装完成！\r\n\r\n";  
    end 
    function uninstall_success();virtual;
    begin
        echo "步骤：卸载完成！\r\n\r\n";  
    end 
    private 
    function do_install();
    begin
        do_install_sub();
        echo "\r\n10秒后退出";
        sleep(10000);
        //s := readln();
    end 
    function do_uninstall();
    begin
        do_uninstall_sub();
        echo "\r\n10秒后退出";
        sleep(10000);
        //s := readln();
    end 
    function do_install_sub();
    begin
        if not install_check() then 
        begin
            echo "提示：安装检查失败。\r\n";
            return ;
        end 
        dllclsid := get_clsid();
        subid := "LocalServer32";
        comname := get_com_name();
        dllPath := sysexecname();
        rk := get_classes_key();
        if not ifobj(rk) then 
        begin
            echo "警告：请使用管理员权限执行CMD。\r\n";
            return;
        end 
        tkpath := rk.openKeyA("CLSID\\"+dllclsid+"\\"+subid);
        tkname := rk.openKeyA(comname+"\\CLSID");
        if 0=tkpath.SetValueStringA(nil,dllPath) then 
        begin
            echo "步骤：注册执行程序成功。\r\n";
        end 
        else 
        begin 
            echo "步骤：注册执行程序失败。\r\n";
            return ;
        end 
        if 0= tkname.SetValueStringA(nil,dllclsid) then  
        begin
            echo "步骤：写入clsid成功。\r\n";
        end else 
        begin
            echo "警告：写入clsid失败。\r\n";  
            return ;  
        end  
        install_success();
    end 
    function get_classes_key(); //
    begin
        if install_for_all_users() then //安装到本机
        begin
            rk :=  new TRegKey(class(TRegKey).HKEY_LOCAL_MACHINE); 
        end else  //安装到当前用户
        begin  
            rk :=  new TRegKey(class(TRegKey).HKEY_CURRENT_USER);
        end 
        return rk.openKeyA("Software\\Classes");
    end     
    function do_uninstall_sub();
    begin
        dllclsid := get_clsid();
        comname := get_com_name();
        rk := get_classes_key();
        if not ifobj(rk) then 
        begin 
            echo "警告：请使用管理员权限执行。\r\n";	
            return;
        end 
        else 
        begin 
            id := rk.openKeyA(comname+"\\CLSID").GetValueA();
            if not ifstring(id) then 
            begin
                echo "警告：没有安装,不需要卸载！\r\n"; 
                return ;
            end          
            if rk.DeleteTreeA(comname)=0   then 
            begin
                echo "步骤：注册表删除com名成功！\r\n";  
        
            end else 
            begin
                echo "警告：删除注册表com名失败！\r\n"; 
                return 0;
            end 
            if rk.DeleteTreeA("CLSID\\"+dllclsid)=0 then 
            begin 
                echo "步骤：注册表删除clsid成功！\r\n";  
            
            end else 
            begin
                echo "警告：删除注册clsid表失败！\r\n";  
                return 0;      
            end   
            uninstall_success();     
            return ;
        end 
    end 
    function run_com(); //运行
    begin
        if not fapp then 
        begin
            fapp := initializeapplication();
        end 
        WSAStartup(0,0);
        CoInitializeEx(0,COINIT_Param());
        RegisterFactory();
        fapp.run();
        UnregisterFactory();
    end 
    function RegisterFactory(); //执行注册
    begin
        theFactory := new IClassFactory();  
        theFactory.fcom_mgr := self(true);      
        pUnkForFactory := theFactory._getptr_();
        v := 0;
        dwRegister := 0;
        CoRegisterClassObject(getguid()._getptr_,pUnkForFactory,4,1,v);
        dwRegister:= v;
    end 
    procedure UnregisterFactory(); //执行退出
	   begin
	       if dwRegister<>0 then 
	       begin
	           CoRevokeClassObject(dwRegister);    
	       end 
	       {if theFactory then 
	       begin
	           theFactory.release();
	       end }
	       theFactory := nil;	       
	   end 
	   function getguid();
	   begin
	       if not sguid then 
	       begin 
	           sguid := new tguid();
	           sguid.readstr(get_clsid());
	       end 
	       return sguid;
	   end 
end 
implementation
type tcom_const = class
    static const E_NOTIMPL=0x80004001L;
    static const E_NOINTERFACE=0x80004002L;
    static const E_INVALIDARG=0x80070057L;
    {    
    static const VT_EMPTY	= 0;
    static const VT_NULL	= 1;
    static const VT_I2	= 2;
    static const VT_I4	= 3;
    static const VT_R4	= 4;
    static const VT_R8	= 5;
    static const VT_CY	= 6;
    static const VT_DATE	= 7;
    static const VT_BSTR	= 8;
    static const VT_DISPATCH	= 9;
    static const VT_ERROR	= 10;
    static const VT_BOOL	= 11;
    static const VT_VARIANT	= 12;
    static const VT_UNKNOWN	= 13;
    static const VT_DECIMAL	= 14;
    static const VT_I1	= 16;
    static const VT_UI1	= 17;
    static const VT_UI2	= 18;
    static const VT_UI4	= 19;
    static const VT_I8	= 20;
    static const VT_UI8	= 21;
    static const VT_INT	= 22;
    static const VT_UINT	= 23;
    static const VT_VOID	= 24;
    static const VT_HRESULT	= 25;
    static const VT_PTR	= 26;
    static const VT_SAFEARRAY	= 27;
    static const VT_CARRAY	= 28;
    static const VT_USERDEFINED	= 29;
    static const VT_LPSTR	= 30;
    static const VT_LPWSTR	= 31;
    static const VT_RECORD	= 36;
    static const VT_INT_PTR	= 37;
    static const VT_UINT_PTR	= 38;
    static const VT_FILETIME	= 64;
    static const VT_BLOB	= 65;
    static const VT_STREAM	= 66;
    static const VT_STORAGE	= 67;
    static const VT_STREAMED_OBJECT	= 68;
    static const VT_STORED_OBJECT	= 69;
    static const VT_BLOB_OBJECT	= 70;
    static const VT_CF	= 71;
    static const VT_CLSID	= 72;
    static const VT_VERSIONED_STREAM	= 73;
    static const VT_BSTR_BLOB	= 0xfff;
    static const VT_VECTOR	= 0x1000;
    static const VT_ARRAY	= 0x2000;
    static const VT_BYREF	= 0x4000;
    static const VT_RESERVED	= 0x8000;
    static const VT_ILLEGAL	= 0xffff;
    static const VT_ILLEGALMASKED	= 0xfff;
    static const VT_TYPEMASK	= 0xfff;
    }

end 

type tguid=class(tslcstructureobj)
    public
    function create(ptr)
    begin
        inherited create(getstruct(),ptr);
    end
    function readstr(s);
    begin
        r := __getid(s);
        _setvalue_("data1",r[0]);
        _setvalue_("data2",r[1]);
        _setvalue_("data3",r[2]);
        _setvalue_("data4",r[3:]);
    end  
    function asstr(); //转换为
    begin
        r := _getdata_();
        s := "{";
        s += format("%8X",R["data1"]);
        s+="-";
        s += format("%4X",R["data2"]);
        s+="-";
        s += format("%4X",R["data3"]);
        s+="-";
        for i:= 0 to 1 do 
        begin
            s+=format("%2x",r["data4",i]);
        end 
        s+="-";
        for i:= 2 to 7 do 
        begin
            s+=format("%2x",r["data4",i]);
        end
        s+="}";
        return replacetext(s," ","0");
    end    
    function equ(riid); //相等
    begin
        if ifstring(riid) then return asstr()=riid;
        if ifarray(riid) then 
        begin
            return _getdata_()=riid ;
        end 
        if riid>0 or riid<0 then 
        begin
            d := _getdata_();
            o := new tguid(riid);
            return d=o._getdata_();
        end 
        return false;
    end 
    private 
    class function getstruct()
    begin
        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
                ("data1","int",0xf59a8177),
                ("data2","short",0x2a0),
                ("data3","short",0x4019),
                ("data4","byte[8]",array(0xa3, 0x93, 0xaf, 0x7, 0x9f, 0x9a, 0xb3, 0x62)),
                )
                );
        return SSTRUCT;
    end
    function __getid(clsid);
    begin
        //clsid := getmycomregclsid(); //"{F59A8177-02A0-4019-A393-AF079F9AB361}";
        r := zeros(11);
        guidinfo := array(8,4,4,2,2,2,2,2,2,2,2);
        num := inttostr(0->9);
        sym := array("A","B","C","D","E","F");
        hs := array();
        for i,v in num do hs[v] := true;
        for i,v in sym do hs[v] := true;
        for i,v in lowercase(sym) do hs[v] := true;
        idx := 0;
        vvi := "";
        for i:= 1 to length(clsid) do 
        begin
            vi := clsid[i];
            if length(vvi)=guidinfo[idx] then 
            begin
                r[idx] := eval(&("0x"+vvi));
                idx++;
                vvi := "";
            end 
            if not(hs[vi]) then continue;
            vvi+=vi;    
        end 
        return r;
    end 
end 

type tagVARIANT =class(tslcstructureobj)
    private 
    class function getstruct()
    begin
        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
                ("vt","short",0),
                ("wReserved1","short",0),
                ("wReserved2","short",0),
                ("wReserved3","short",0),
                ("data","intptr",0),
                ("data2","intptr",0)
                )
                );
        return SSTRUCT;
    end
    public
    function create(ptr)
    begin
        inherited create(getstruct(),ptr);
    end
end 
type tagDISPPARAMS = class(tslcstructureobj)
    private 
    class function getstruct()
    begin
        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
                ("rgvarg","intptr",0),
                ("rgdispidNamedArgs","intptr",0),
                ("cArgs","int",0),
                ("cNamedArgs","int",0)
                )
                );
        return SSTRUCT;
    end
    public
    function create(ptr)
    begin
        inherited create(getstruct(),ptr);
    end
    function getarg(idx);
    begin
        if (idx >=0) and  (idx<_getvalue_("cArgs")) then 
        begin            
            addri := _getvalue_("rgvarg");
            obj := new tagVARIANT(addri);
            if idx>0 then 
            begin
                addri := int64(addri+idx*obj._size_()); //_tool.readptr(addri+idx*8);
                obj._setcptr_(addri);
            end 
            return obj;
        end 
    end 
    function getArgs(od);
    begin
        r := array();
        ct := _getvalue_("cArgs");
        if ct<1 then return r;
        addri := _getvalue_("rgvarg");
        obj := new tagVARIANT(addri);
        r[0] := obj;
        sz := obj._size_();
        for i:= 1 to ct-1 do 
        begin
            addri+=sz;
            r[i] := new  tagVARIANT(addri);           
        end 
        if not od then 
        begin
            rt := array();
            idx := 0;
            for i:= ct-1 downto 0 do 
            begin
                rt[idx++] := r[i];
            end 
            return rt;
        end  
        return r;
    end 
    property cArgs index "cArgs" read _getvalue_;
end 
type tptrarray =class(tslcstructureobj)
    private 
    class function getstruct()
    begin
        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
                ("ptr","intptr",0)
                )
                );
        return SSTRUCT;
    end
    public
    function create(ptr)
    begin
        inherited create(getstruct(),ptr);
    end
    function ansistr();
    begin
        p := _getvalue_("ptr");
        wlen := uaw_wcslen(p);
        sansi := "";
        setlength(sansi,wlen*2+1);
        WideCharToMultiByte(0,0,p,wlen,sansi,length(sansi),0,0);
        return sansi;
    end 
end 
//////////////////////////vtb/////////////////////////////
type inukownvtbcontainer = class(tslcstructureobj)
    private 
    static SSTRUCT;  
    class function getstruct()
    begin
        if not SSTRUCT then 
        begin        
            SSTRUCT := MemoryAlignmentCalculate(array(
                ("vtable","intptr",0)
                )
                );
        end 
        return SSTRUCT;
    end 
    public 
    function create(ptr);
    begin
        inherited create(getstruct(),ptr);    
    end  
end
 
type iunkown =class(tcom_const)
    protected
    static IID_IUnknown ;//:= new tguid();
    m_dwRef;
    fvtable;
    fvtablecontainer;
    function createvtb(ptr);virtual;
    begin
        return new inukownvtb(ptr);    
    end 
    public 
    function create(ptr);
    begin    
        if not IID_IUnknown then 
        begin 
            IID_IUnknown := new tguid();            
            IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
        end     
        fvtablecontainer := new inukownvtbcontainer(ptr);
        if ptr then 
        begin 
            fvtable := createvtb( fvtablecontainer._getvalue_("vtable"));
        end else 
        begin 
            fvtable := createvtb(nil);
            fvtablecontainer._setvalue_("vtable",fvtable._getptr_());
            fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
            fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
            fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));    
        end 
    end     
    function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
    begin   
        if IID_IUnknown.equ(riid) then 
        begin 
            ppv  := _getptr_();
            AddRef(ppv);
            return 0;
        end 
        return E_NOINTERFACE;
    end 
    function AddRef(s:pointer):integer;stdcall;virtual;
    begin
        m_dwRef++;
        return m_dwRef;
    end 
    function Release(s:pointer):integer;stdcall;virtual;
    begin
        if m_dwRef>0 then m_dwRef--;
        return m_dwRef;
    end 
    function _getptr_();
    begin
        return fvtablecontainer._getptr_();
    end 
end 

type idispatch=class(iunkown)        
    protected
    static  IID_IDispatch;
    function createvtb(ptr);override;
    begin 
        return new idispatchvtb(ptr);
    end 
    public 
    [weakref] fcom_mgr;
    function create(ptr)
    begin
        inherited ;//create(getstruct(),ptr);
        if not IID_IDispatch then 
        begin
            IID_IDispatch := new tguid();
            IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");        
        end 
        if not ptr then 
        begin          
            fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));           
            fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));           
            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));           
            fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));           
        end 
        frgDispIds := array();
        frgDispIds2 := array();
        fglobalL := TS_GetGlobalL();
    end    
    function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
    begin
        pctinfo := 0;
        return 0;
    end 
    function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual;
    begin
        if ppTInfo then ppTInfo := 0;
        return E_NOTIMPL;
    end 
    function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;virtual;
    begin
        if cnames>1 then return E_INVALIDARG; 
        ostr := new tptrarray(rgszNames);        
        rgDispId := getdispid(ostr.ansistr); 
        return 0; 
    end 
    function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer; 
                    pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
    begin
        o := new tagDISPPARAMS(pDispParams);
        pp := o.getArgs();
        pms := array();
        fname := getdispidstr(dispIdMember);
        for idx,p1 in pp do 
        begin 
            VariantToObj2(fglobalL,p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
            pms[idx] := r;
        end         
        x := fcom_mgr.invoke_call(fname,pms);
        ObjToVariantRef(fglobalL,x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
        return 0;
    end 
    function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
    begin        
        if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then 
        begin 
            ppv  := _getptr_();
            addref(ppv);
            return 0;
        end 
        return E_NOINTERFACE;
    end     
    function release(s:pointer):integer;stdcall;override;
    begin
        r := inherited;
        if r=0 and fcom_mgr then fcom_mgr.stop_run();
        return r;            
    end 
    private    
    frgDispIds;
    frgDispIds2;
    fglobalL;
    function getdispid(s);
    begin
        id :=  frgDispIds[s];   
        if id>0  then 
        begin 
            return id;
        end  
        id := length(frgDispIds);
        frgDispIds2[id] := s;
        frgDispIds[s] := id;
    end 
    function getdispidstr(id);
    begin
        return frgDispIds2[id];
    end 
end 

type IClassFactory=class(iunkown)
    static sguid;  
    protected
    static IID_IClassFactory;// := new tguid(); 
    function createvtb(ptr);virtual;
    begin
        return new iClassFactoryvtb(ptr);    
    end 
    public
    [weakref] fcom_mgr;
    function create(ptr);override;
    begin
        inherited ;
        if not IID_IClassFactory then 
        begin
            IID_IClassFactory := new tguid();
            IID_IClassFactory.readstr("{00000001-0000-0000-C000-000000000046}");
        end 
        fdispatchs := array();
        if not ptr then 
        begin
            fvtable._setvalue_("CreateInstance",makeinstance(thisfunction(CreateInstance)));
            fvtable._setvalue_("LockServer",makeinstance(thisfunction(LockServer)));            
        end 
    end
    function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
    begin
        if IID_IUnknown.equ(riid) or IID_IClassFactory.equ(riid) then 
        begin 
            ppv  := _getptr_();
            addref(ppv);
            return 0;
        end         
        return E_NOINTERFACE;
    end  
    
    function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;//
    begin
        if not fdispatchs then 
        begin        
            fdispatchs := new idispatch();
            fdispatchs.fcom_mgr := fcom_mgr;
        end 
        hr := fdispatchs.QueryInterface(fdispatchs._getptr_(),riid,ppvObject);
        return hr;
    end 
    function LockServer(lk:integer):integer;stdcall;virtual;
    begin
        return 1;
    end 
    private
    static dwRegister;    
    static theFactory;
    fdispatchs; 
end 
type ishelllinkavtb = class(inukownvtb)
    function create(ptr);
    begin
        inherited;
    end 
    protected 
    function get_vtb_struct();override;
    begin
        return inherited union  array(
                ("GetPath","intptr",0),
                ("GetIDList","intptr",0),
                ("SetIDList","intptr",0),
                ("GetDescription","intptr",0),
                ("SetDescription","intptr",0),
                ("GetWorkingDirectory","intptr",0),
                ("SetWorkingDirectory","intptr",0),
                ("GetArguments","intptr",0),
                ("SetArguments","intptr",0),
                ("GetHotkey","intptr",0),
                ("SetHotkey","intptr",0),
                ("GetShowCmd","intptr",0),
                ("SetShowCmd","intptr",0),
                ("GetIconLocation","intptr",0),
                ("SetIconLocation","intptr",0),
                ("SetRelativePath","intptr",0),
                ("Resolve","intptr",0),
                ("SetPath","intptr",0)
                );
    end 
end
type iPersistFilevtb = class(inukownvtb)
    function create(ptr);
    begin
        inherited;
    end 
    protected 
    function get_vtb_struct();override;
    begin
        return inherited union  array(
                ("GetClassID","intptr",0),
                ("IsDirty","intptr",0),
                ("Load","intptr",0),
                ("Save","intptr",0),
                ("SaveCompleted","intptr",0),
                ("GetCurFile","intptr",0)
                );
    end 
end 
type IShellLink=class(iunkown)  //"000214EE-0000-0000-C000-000000000046"
    protected
    function createvtb(ptr);override;
    begin
        return new ishelllinkavtb(ptr);
    end 
    public
    function create(ptr);override;
    begin
        inherited ;
    end
    function Destroy();virtual;
    begin
        release(nil);
    end 
    function AddRef(s):integer;override;
    begin
        f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("AddRef"); 
        if not s then s := _getptr_();
        return call(f,_getptr_());
    end 
    function Release(s):integer;override;
    begin
        f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("Release"); ;
        if not s then s := _getptr_();
        return call(f,s);
    end 
    function QueryInterface(s,riid,ppv):integer;virtual;
    begin  
        f := function(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;external fvtable._getvalue_("QueryInterface");;
        if not s then s := _getptr_();
        return call(f,s,riid,ppv);
    end  
    function SetPath(s:pointer;target:widestring):integer;stdcall;virtual;
    begin
        ptr := fvtable._getvalue_("SetPath");
        f := function(s:pointer;target:widestring):integer;stdcall ;external ptr;
        if not s then s := _getptr_();
        R :=  ##f(s,target);
        RETURN R;
    end 
    function SetDescription(s:pointer;descrip:widestring):integer;stdcall;virtual;
    begin
        f := function(s:pointer;descrip:widestring):integer;stdcall;external fvtable._getvalue_("SetDescription");
        if not s then s := _getptr_();
        return call(f,s,t);
    end 
    function get_persistfile();
    begin
    {**
        @explan(说明) 获取 文件保存对象 %%
        @return(IPersistFile)  对象 %%  
    **}
        fclsid := new tguid();
        fclsid.readstr("{0000010b-0000-0000-C000-000000000046}");
        if 0<>QueryInterface(nil,fclsid._getptr_(),v2) then 
        begin   
            return -1;
        end 
        return  new IPersistFile(v2);
    end 
end
type IPersistFile=class(iunkown)  //"0000010b-0000-0000-C000-000000000046"
    protected
    function createvtb(ptr);override;
    begin
        return new iPersistFilevtb(ptr);
    end 
    public
    function create(ptr);override;
    begin
        inherited ;
    end
    function Destroy();virtual;
    begin
        Release(nil);
    end 
    function addref(s:pointer):integer;stdcall;override;
    begin
        ptr := fvtable._getvalue_("AddRef");
        f := function(s:pointer):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        return call(f,s);    
    end 
    function Release(s:pointer):integer;stdcall;override;
    begin
        ptr := fvtable._getvalue_("AddRef");
        f := function(s:pointer):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        return call(f,s); 
        
    end 
    function IsDirty(s:pointer):integer;stdcall;virtual;
    begin
        ptr := fvtable._getvalue_("IsDirty");
        f := function(s:pointer):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        return call(f,s);
    end  
    function Load(s:pointer;fn:widestring;md:integer):integer;stdcall;virtual;
    begin
        ptr := fvtable._getvalue_("Load");
        f := function(s:pointer;fn:string;dwmode:integer):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        return call(f,s,fn,md);
    end 
    function Save(s:pointer;fn:widestring;Remember:integer):integer;stdcall;virtual;
    begin
        ptr := fvtable._getvalue_("Save");
        f := function(s:pointer;fn:widestring;remember:integer):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        r := call(f,s,fn,Remember);
        return r;
    end 
    function SaveCompleted(s:pointer;fn:widestring);
    begin
        ptr := fvtable._getvalue_("SaveCompleted");
        f := function(s:pointer;fn:widestring):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        return call(f,s,fn);
    end 
    function GetCurFile(s:pointer;fn:widestring);
    begin
        ptr := fvtable._getvalue_("GetCurFile");
        f := function(fn:pointer):integer;stdcall;external ptr;
        if not s then s := _getptr_();
        return call(f,s,fn);
    end
end
function sh_get_IShellLinkW(); //获取快捷方式创建接口
begin
{
    @explan(说明) 获取快捷方式构建接口 %%
    @return(IShellLink) 接口对象 %%;
}
    if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
    hd := int64(obj);
    aic := new IShellLink(hd);
    aic.addref();
    cls := new tguid();
    cls.readstr("{000214F9-0000-0000-C000-000000000046}");
    if 0 <> aic.QueryInterface(hd,cls._getptr_(),v) then return -1;
    ilink :=  new IShellLink(v); 
    return ilink; 
end 
function create_short_cutA(targ,lnk);//创建文件快捷方式
begin    
    if not fileexists("",targ) then return -1;
    if not ifstring(lnk) then return -1;
    ilink := sh_get_IShellLinkW();
    if not ifobj(ilink) then return -1;
    ilink.SetPath(nil,widestring(targ));
    ifile := ilink.get_persistfile();
    return ifile.save(nil,widestring(lnk),true); 
    ///////////////////////////////////////////////////
    if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
    hd := int64(obj);
    aic := new IShellLink(hd);
    aic.addref();
    cls := new tguid();
    cls.readstr("{000214F9-0000-0000-C000-000000000046}");
    if 0 <> aic.QueryInterface(hd,cls._getptr_(),v) then return -1;
    ilink :=  new IShellLink(v);  
    ilink.SetPath(nil,widestring(targ));
    fclsid := new tguid();
    fclsid.readstr("{0000010b-0000-0000-C000-000000000046}");
    if 0<>ilink.QueryInterface(nil,fclsid._getptr_(),v2) then 
    begin   
        return -1;
    end 
    ifile := new IPersistFile(v2);
    return ifile.save(nil,widestring(lnk),true);     
end
function CoCreateInstance(rclsid:pointer;pUnk:pointer;dwClsContext:integer;riid:integer;var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoCreateInstance";
function CoRegisterClassObject(rclsid:pointer;pUnk:pointer;dwClsContext:integer;flags:integer;var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRegisterClassObject";

function CoRevokeClassObject(var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRevokeClassObject";
function WSAStartup(q:short;d:pointer):integer; stdcall; external "Ws2_32.dll" name "WSAStartup";
function CoInitializeEx(q:pointer;d:integer):integer; stdcall; external "ole32.dll" name "CoInitializeEx";
procedure VariantToObj2(L:pointer;  V:pointer; var o:TObject;isIndex:integer);cdecl;external "tslkrnl.dll" name "VariantToObj2";
procedure ObjToVariantRef(L:pointer;o:TObject; v:pointer; IsExcel:integer);cdecl;external "tslkrnl.dll" name "ObjToVariantRef";
function TS_GetGlobalL():pointer;cdecl;external "TSSVRAPI.dll"  name "TS_GetGlobalL";
function uaw_wcslen(s:pointer):integer;stdcall;external "Kernel32.dll" name "uaw_wcslen";
function WideCharToMultiByte(CodePage:integer;dwFlags:integer;lpWideCharStr:pointer;
                            cchWideChar:integer;var lpMultiByteStr:string;cbMultiByte:integer;
                            lpDefaultChar:pointer;var lpUsedDefaultChar:integer):integer;stdcall;external "Kernel32.dll" name "WideCharToMultiByte";
function MultiByteToWideChar(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;
                            cchMultiByte:integer;var lpWideCharStr:pointer;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar";
initialization
end.