编辑器

修正赋值运算符问题

designer/utslcodeeditor.tsf

@@ -1792,9 +1792,12 @@ type TEditer=class(TCustomcontrol) //
             if not it then return ;
             if it.fisnewfile then  //单独处理新建关闭
             begin 
-                f := it.OrigScriptPath;
+                if MessageboxA("新建文件还未保存!关闭将删除","提示",1,self)= IDOK then 
-                DeletePageItem(it);
+                begin
-                if fileexists("",f) then filedelete("",f);                    
+                    f := it.OrigScriptPath;
+                    DeletePageItem(it);
+                    if fileexists("",f) then filedelete("",f); 
+                end                    
             
             end else 
             begin 

designer/utslcodeformat.tsf

@@ -290,7 +290,7 @@ type TFormatParser = class
             FCWordCount :=0;  
             FLWordLength :=0;      
         end else 
-        if (tk.FType .& TK_SYN_S) and (tk.FStr="*") then  //ÐÞÕý(**) ÎÊÌâ
+        if (tk.FType .& TK_SYN_S){ and (tk.FStr="*")} then  //ÐÞÕý(**) ÎÊÌâ 20231127ÐÞÕý
         begin
             FFormatStr+= " "+tk.FStr+" ";    
         end else

funcext/tvclib/tgdiplusflat.tsf

@@ -425,11 +425,11 @@ type TGdiplusflat=class()
     end 
  class function CreateStreamOnHGlobal(hGlobal:pointer;fDeleteOnRelease:integer; var ppstm:pointer):pointer;stdcall;external "Ole32.dll"  name "CreateStreamOnHGlobal";
  class function  GetHGlobalFromStream(pstm:pointer; var phglobal:pointer):pointer;stdcall;external "Ole32.dll"  name "GetHGlobalFromStream";
-	class 	function GlobalLock(mem :pointer):pointer;stdcall;external "Kernel32.dll"  name "GlobalLock";
+	class function GlobalLock(mem :pointer):pointer;stdcall;external "Kernel32.dll"  name "GlobalLock";
-	class 	function GlobalUnlock(mem :pointer):integer;stdcall;external "Kernel32.dll"  name "GlobalUnlock";
+	class function GlobalUnlock(mem :pointer):integer;stdcall;external "Kernel32.dll"  name "GlobalUnlock";
-	class 	function GlobalSize(menm:pointer):integer;stdcall;external "Kernel32.dll"  name "GlobalSize";
+	class function GlobalSize(menm:pointer):integer;stdcall;external "Kernel32.dll"  name "GlobalSize";
 	class function memcpy(dst:pointer;src:string;size_t:integer):pointer;cdecl;external "msvcrt.dll"  name "memcpy";
-	class 	function memcpy2(var dst:string;src:pointer;size_t:integer):pointer;cdecl;external "msvcrt.dll"  name "memcpy";
+	class function memcpy2(var dst:string;src:pointer;size_t:integer):pointer;cdecl;external "msvcrt.dll"  name "memcpy";
 	class function tuicloseistream(sm:pointer);
 	begin
 	    	r := tslvclcloseistream(sm);

funcext/tvclib/utslvcl_com.tsf

@@ -18,6 +18,7 @@ interface
     com := new my_com();
     return com.do_command();
     type my_com=class(t_com_class)
+        uses utslvcl_com;
         function create();
         begin
             inherited;
@@ -32,18 +33,55 @@ interface
         end
     end 
 *)
-uses tslvcl;
+uses  cstructurelib,tslvcl;
+function sh_get_IShellLinkW(); //获取快捷方式创建接口
 function create_short_cutA(targ,lnk);//创建文件快捷方式
-type tiunkown = class(iunkown) //对外输出com接口
+type inukownvtb = class(tslcstructureobj)
-    function create(ptr)
+    function create(ptr);
     begin
-        inherited;
+        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 tIClassFactory = class(IClassFactory)
+type idispatchvtb =class(inukownvtb)
+    public
     function create(ptr)
     begin
-        inherited;
+        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对象 
@@ -118,6 +156,7 @@ type t_com_class = class()
                 return do_uninstall();
             end  
         end 
+        //sleep(10000);
     end 
     function install_success();virtual;
     begin
@@ -131,14 +170,16 @@ type t_com_class = class()
     function do_install();
     begin
         do_install_sub();
-        echo "\r\n输入回车键退出";
+        echo "\r\n10秒后退出";
-        s := readln();
+        sleep(10000);
+        //s := readln();
     end 
     function do_uninstall();
     begin
         do_uninstall_sub();
-        echo "\r\n输入回车键退出";
+        echo "\r\n10秒后退出";
-        s := readln();
+        sleep(10000);
+        //s := readln();
     end 
     function do_install_sub();
     begin
@@ -336,19 +377,6 @@ type tcom_const = class
 end 
 
 type tguid=class(tslcstructureobj)
-    uses cstructurelib;
-    private
-    class function getstruct()
-    begin
-        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
-                ("data1","int",0xf59a8177),
-                ("data2","short",0x2a0),
-                ("data3","short",0x4019),
-                ("data4","byte[8]",array(0xa3, 0x93, 0xaf, 0x7, 0x9f, 0x9a, 0xb3, 0x62)),
-                )
-                );
-        return SSTRUCT;
-    end
     public
     function create(ptr)
     begin
@@ -362,6 +390,55 @@ type tguid=class(tslcstructureobj)
         _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}";
@@ -389,24 +466,9 @@ type tguid=class(tslcstructureobj)
         end 
         return r;
     end 
-    function equ(riid);
-    begin
-        if ifarray(riid) then 
-        begin
-            return _getdata_()=riid ;
-        end 
-        if riid>0 then 
-        begin
-            d := _getdata_();
-            o := new tguid(riid);
-            return d=o._getdata_();
-        end 
-        return false;
-    end 
 end 
 
 type tagVARIANT =class(tslcstructureobj)
-    uses cstructurelib;
     private 
     class function getstruct()
     begin
@@ -428,7 +490,6 @@ type tagVARIANT =class(tslcstructureobj)
     end
 end 
 type tagDISPPARAMS = class(tslcstructureobj)
-    uses cstructurelib;
     private 
     class function getstruct()
     begin
@@ -489,7 +550,6 @@ type tagDISPPARAMS = class(tslcstructureobj)
     property cArgs index "cArgs" read _getvalue_;
 end 
 type tptrarray =class(tslcstructureobj)
-    uses cstructurelib;
     private 
     class function getstruct()
     begin
@@ -514,26 +574,14 @@ type tptrarray =class(tslcstructureobj)
         return sansi;
     end 
 end 
-
+//////////////////////////vtb/////////////////////////////
-type iunkown =class(tslcstructureobj,tcom_const)
+type inukownvtbcontainer = class(tslcstructureobj)
-    uses cstructurelib;
     private 
     static SSTRUCT;  
-    protected
-    static IID_IUnknown ;//:= new tguid();
-    static IID_IDispatch;// := new tguid();
-    m_dwRef;
-    fvtable;
     class function getstruct()
     begin
         if not SSTRUCT then 
         begin        
-            IID_IUnknown := new tguid();
-            
-            
-            IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
-            
-
             SSTRUCT := MemoryAlignmentCalculate(array(
                 ("vtable","intptr",0)
                 )
@@ -542,46 +590,145 @@ type iunkown =class(tslcstructureobj,tcom_const)
         return SSTRUCT;
     end 
     public 
-    function create(ptr)
+    function create(ptr);
     begin
         inherited create(getstruct(),ptr);    
     end  
-    function addref(s:pointer):integer;stdcall;
+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++;
-        //echo "\r\nidispath addref:",s,"====",m_dwRef;
         return m_dwRef;
     end 
-    function release(s:pointer):integer;stdcall;virtual;
+    function Release(s:pointer):integer;stdcall;virtual;
     begin
         if m_dwRef>0 then m_dwRef--;
         return m_dwRef;
     end 
-end 
+    function _getptr_();
-type dispatchvtable =class(tslcstructureobj)
-    uses cstructurelib;
-    private 
-    class function getstruct()
     begin
-        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
+        return fvtablecontainer._getptr_();
-                ("QueryInterface","intptr",0),
+    end 
-                ("AddRef","intptr",0),
+end 
-                ("Release","intptr",0),
+
-                ("GetTypeInfoCount","intptr",0),
+type idispatch=class(iunkown)        
-                ("GetTypeInfo","intptr",0),
+    protected
-                ("GetIDsOfNames","intptr",0),
+    static  IID_IDispatch;
-                ("Invoke","intptr",0)
+    function createvtb(ptr);override;
-                )
+    begin 
-                );
+        return new idispatchvtb(ptr);
-        return SSTRUCT;
     end 
     public 
+    [weakref] fcom_mgr;
     function create(ptr)
     begin
-        inherited create(getstruct(),ptr);
+        inherited ;//create(getstruct(),ptr);
+        if not IID_IDispatch then 
+        begin
+            IID_IDispatch := new tguid();
+            IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");        
+        end 
+        if not ptr then 
+        begin          
+            fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));           
+            fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));           
+            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));           
+            fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));           
+        end 
+        frgDispIds := array();
+        frgDispIds2 := array();
+    end    
+    function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
+    begin
+        pctinfo := 0;
+        return 0;
+    end 
+    function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual;
+    begin
+        if ppTInfo then ppTInfo := 0;
+        return E_NOTIMPL;
+    end 
+    function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;virtual;
+    begin
+        if cnames>1 then return E_INVALIDARG; 
+        ostr := new tptrarray(rgszNames);        
+        rgDispId := getdispid(ostr.ansistr); 
+        return 0; 
+    end 
+    function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer; 
+                    pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
+    begin
+        o := new tagDISPPARAMS(pDispParams);
+        pp := o.getArgs();
+        pms := array();
+        fname := getdispidstr(dispIdMember);
+        for idx,p1 in pp do 
+        begin 
+            VariantToObj2(TS_GetGlobalL(),p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
+            pms[idx] := r;
+        end         
+        x := fcom_mgr.invoke_call(fname,pms);
+        ObjToVariantRef(TS_GetGlobalL(),x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
+        return 0;
+    end 
+    function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
+    begin        
+        if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then 
+        begin 
+            ppv  := _getptr_();
+            addref(ppv);
+            return 0;
+        end 
+        return E_NOINTERFACE;
+    end     
+    function release(s:pointer):integer;stdcall;override;
+    begin
+        r := inherited;
+        if r=0 and fcom_mgr then fcom_mgr.stop_run();
+        return r;            
     end 
-end 
-type idispatch=class(iunkown)    
     private    
     frgDispIds;
     frgDispIds2;
@@ -600,117 +747,16 @@ type idispatch=class(iunkown)
     begin
         return frgDispIds2[id];
     end 
-    protected
+end 
-    static  IID_IDispatch;
-    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 := new  dispatchvtable();
-            _setvalue_("vtable",fvtable._getptr_());                       
-            fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
-            fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
-            fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));           
-            fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));           
-            fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));           
-            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));           
-            fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));           
-        end else 
-        begin    
-            fvtable := new fvtable(_getvalue_("vtable"));
-            m_dwRef := 0;
-        end 
-        frgDispIds := array();
-        frgDispIds2 := array();
-    end    
-    function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;
-    begin
-        pctinfo := 0;
-        return 0;
-    end 
-    function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;
-    begin
-        if ppTInfo then ppTInfo := 0;
-        return E_NOTIMPL;
-    end 
-    function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;
-    begin
-        if cnames>1 then return E_INVALIDARG; 
-        ostr := new tptrarray(rgszNames);        
-        rgDispId := getdispid(ostr.ansistr); 
-        return 0; 
-    end 
-    function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer; pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;
-    begin
-        o := new tagDISPPARAMS(pDispParams);
-        pp := o.getArgs();
-        pms := array();
-        fname := getdispidstr(dispIdMember);
-        for idx,p1 in pp do 
-        begin 
-            VariantToObj2(TS_GetGlobalL(),p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
-            pms[idx] := r;
-        end         
-        x := fcom_mgr.invoke_call(fname,pms);
-        ObjToVariantRef(TS_GetGlobalL(),x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
-        return 0;
-    end 
-    function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;
-    begin        
-        if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then 
-        begin 
-            ppv  := _getptr_();
-            addref(ppv);
-            return 0;
-        end 
-        return E_NOINTERFACE;
-    end 
 
-    function release(s:pointer):integer;stdcall;override;
-    begin
-        r := inherited;
-        //echo "\r\nidispath release:",s,"====",r;
-        if r=0 and fcom_mgr then fcom_mgr.stop_run();
-        return r;            
-    end 
-end 
-type ClassFactoryvtable = class(tslcstructureobj)
-    uses cstructurelib;
-    private 
-    class function getstruct()
-    begin
-        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
-                ("QueryInterface","intptr",0),
-                ("AddRef","intptr",0),
-                ("Release","intptr",0),
-                ("CreateInstance","intptr",0),
-                ("LockServer","intptr",0)
-                )
-                );
-        return SSTRUCT;
-    end
-    public
-    function create(ptr)
-    begin
-        inherited create(getstruct(),ptr);
-    end
-end 
 type IClassFactory=class(iunkown)
     static sguid;  
-    private
-    static dwRegister;    
-    static theFactory;
-    fdispatchs;   
     protected
     static IID_IClassFactory;// := new tguid(); 
+    function createvtb(ptr);virtual;
+    begin
+        return new iClassFactoryvtb(ptr);    
+    end 
     public
     [weakref] fcom_mgr;
     function create(ptr);override;
@@ -724,21 +770,11 @@ type IClassFactory=class(iunkown)
         fdispatchs := array();
         if not ptr then 
         begin
-            fvtable := new  ClassFactoryvtable();
-            _setvalue_("vtable",fvtable._getptr_());                       
-            fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
-            fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
-            fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
             fvtable._setvalue_("CreateInstance",makeinstance(thisfunction(CreateInstance)));
             fvtable._setvalue_("LockServer",makeinstance(thisfunction(LockServer)));            
-            
-        end else 
-        begin           
-            fvtable := new fvtable(_getvalue_("vtable"));
-            m_dwRef := 0;
         end 
     end
-    function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
+    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 
@@ -748,13 +784,8 @@ type IClassFactory=class(iunkown)
         end         
         return E_NOINTERFACE;
     end  
-    function release(s:pointer):integer;stdcall;override;
+    
-    begin
+    function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;//
-        r := inherited;
-        //echo "\r\nIClassFactory release:",s,"====",r;
-        return r;
-    end 
-    function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;//
     begin
         if not fdispatchs then 
         begin        
@@ -764,60 +795,24 @@ type IClassFactory=class(iunkown)
         hr := fdispatchs.QueryInterface(fdispatchs._getptr_(),riid,ppvObject);
         return hr;
     end 
-    function LockServer(lk:integer):integer;stdcall;
+    function LockServer(lk:integer):integer;stdcall;virtual;
     begin
         return 1;
     end 
-end
- 
-type trelease = class()
     private
-    [weakref]freleases;
+    static dwRegister;    
-    public 
+    static theFactory;
-    function create();
+    fdispatchs; 
-    begin
-        freleases := array();
-    end 
-    function add(o);
-    begin
-        for i,v in freleases do 
-        begin
-            if o= v then return ;
-        end 
-        freleases[length(freleases)] := o;
-    end 
-    function del(o);
-    begin
-        for i := 0 to length(freleases)-1 do 
-        begin
-            if freleases[i]=0 then 
-            begin 
-                return deleteindex(freleases,i,true);
-            end 
-        end 
-    end 
-    function Destroy();
-    begin
-        for i,v in freleases do 
-        begin
-            if v then 
-                v.Release();
-        end 
-        freleases := array();
-    end 
-    
-
 end 
-
+type ishelllinkavtb = class(inukownvtb)
-type ishelllinkavtable =class(tslcstructureobj)
+    function create(ptr);
-    uses cstructurelib;
-    private 
-    class function getstruct()
     begin
-        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
+        inherited;
-                ("QueryInterface","intptr",0),
+    end 
-                ("AddRef","intptr",0),
+    protected 
-                ("Release","intptr",0),
+    function get_vtb_struct();override;
+    begin
+        return inherited union  array(
                 ("GetPath","intptr",0),
                 ("GetIDList","intptr",0),
                 ("SetIDList","intptr",0),
@@ -836,55 +831,41 @@ type ishelllinkavtable =class(tslcstructureobj)
                 ("SetRelativePath","intptr",0),
                 ("Resolve","intptr",0),
                 ("SetPath","intptr",0)
-                )
                 );
-        return SSTRUCT;
-    end
-    public
-    function create(ptr)
-    begin
-        inherited create(getstruct(),ptr);
     end 
 end
-type iPersistFilevtable =class(tslcstructureobj)
+type iPersistFilevtb = class(inukownvtb)
-    uses cstructurelib;
+    function create(ptr);
-    private 
-    class function getstruct()
     begin
-        if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
+        inherited;
-                ("QueryInterface","intptr",0),
+    end 
-                ("AddRef","intptr",0),
+    protected 
-                ("Release","intptr",0),
+    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)
-                )
                 );
-        return SSTRUCT;
-    end
-    public
-    function create(ptr)
-    begin
-        inherited create(getstruct(),ptr);
     end 
 end 
-type IShellLink=class(tiunkown)  //"000214EE-0000-0000-C000-000000000046"
+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 ;
-        fdispatchs := array();
+    end
-        if not ptr then 
+    function Destroy();virtual;
-        begin
+    begin
-            fvtable := new  ishelllinkavtable();
+        release(nil);
-            _setvalue_("vtable",fvtable._getptr_());                       
-        end else 
-        begin           
-            fvtable := new ishelllinkavtable(_getvalue_("vtable"));
-        end 
     end 
     function AddRef(s):integer;override;
     begin
@@ -918,23 +899,35 @@ type IShellLink=class(tiunkown)  //"000214EE-0000-0000-C000-000000000046"
         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"
-type IPersistFile=class(tiunkown)  //"0000010b-0000-0000-C000-000000000046"
+    protected
+    function createvtb(ptr);override;
+    begin
+        return new iPersistFilevtb(ptr);
+    end 
     public
     function create(ptr);override;
     begin
         inherited ;
-        fdispatchs := array();
+    end
-        if not ptr then 
+    function Destroy();virtual;
-        begin
+    begin
-            fvtable := new  iPersistFilevtable();
+        Release(nil);
-            _setvalue_("vtable",fvtable._getptr_());                                   
-        end else 
-        begin           
-            fvtable := new iPersistFilevtable(_getvalue_("vtable"));
-            m_dwRef := 0;
-        end 
     end 
     function addref(s:pointer):integer;stdcall;override;
     begin
@@ -988,28 +981,48 @@ type IPersistFile=class(tiunkown)  //"0000010b-0000-0000-C000-000000000046"
         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;
-    rels := new trelease();
+    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);
-    cls := new tclsguid();
+    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);  
-    rels.add(ilink);   
     ilink.SetPath(nil,widestring(targ));
-    fclsid := new tclsguid();
+    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);
-    rels.add(ifile); 
     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";
@@ -1027,9 +1040,5 @@ function WideCharToMultiByte(CodePage:integer;dwFlags:integer;lpWideCharStr:poin
                             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.

funcext/tvclib/utslvclgdi.tsf

@@ -955,6 +955,12 @@ type tcustomimage=class(TSLUIBASE)
     begin
         inherited;
     end
+    function LoadFromstr(p);
+    begin  
+        if not(ifstring(p) and p) then return -1 ;
+        if fileexists("",p) then return  LoadFromFile(p);
+        return StringToImage(p);
+    end 
     function LoadFromFile(path);
     begin
         {**
@@ -986,9 +992,9 @@ type tcustomimage=class(TSLUIBASE)
         @param(p)(string)路径 %%
         @param(t)(string)类型 ,"png" "bmp" "gif"
         **}
-        if not ifstring(p)then return-1;
+        if not ifstring(p)then return -1;
         if not ifstring(t)then t := "png";
-        if not FHandle then return-1;
+        if not FHandle then return -1;
         vp := GetFileType(t);
         fn := _wapi.AnsiToWidChar(p);
         return Gdi.GdipSaveImageToFile(FHandle,fn,vp._getptr_(),0);
@@ -1102,7 +1108,6 @@ type TPicturebase=class(TSLUIBASE)
     end
     property Image read FImage;
 end
-
 type TcustomBitmap = class(TPicturebase)
     {**
     @explan(说明) bitmap 类 %%
@@ -1169,28 +1174,28 @@ type TcustomBitmap = class(TPicturebase)
             _wapi.GetObjectA(FHandle,FBitmap._size_(),FBitmap._getptr_());
         end
     end
-    function setid(id);virtual;
+    function setid(aid);virtual;
     begin
         {**
         @explan(说明) 设置id %%;
         **}
-        if id <> FId then
+        if aid <> FId then
         begin
-            Fid := id;
+            Fid := aid;
             DestroyHandle();
-            if ifnumber(id)then h := loadsysbmp(id);
+            if ifnumber(aid)then h := loadsysbmp(aid);
             if h then
             begin
                 AutoDestroy := false; //不删除
             end else
             begin
-                h := getresourcebyid(id,array("type":"bmp"));
+                //h := getresourcebyid(aid,array("type":"bmp"));
                 if not h then
                 begin
                     if Image then
                     begin
                         //echo "\r\nloadok:",
-                        Image.LoadFromFile(id);
+                        Image.LoadFromstr(aid);
                         //echo "\r\n=================readhandle:",Image.Handle;
                         h := Image.ToHbitmap();
                     end
@@ -1204,20 +1209,20 @@ type TcustomBitmap = class(TPicturebase)
         end
     end
     protected
-    class function loadsysbmp(id);virtual;
+    class function loadsysbmp(aid);virtual;
     begin
         {**
         @explan(说明) 获取系统的bitmap句柄 %%
-        @param(id)(menuber of TSystemBitmap) id %%
+        @param(aid)(menuber of TSystemBitmap) id %%
         @return(hbitmap) 句柄 %%
         **}
         if not ifarray(FsysBitmaps)then FsysBitmaps := array();
-        r := FsysBitmaps[id];
+        r := FsysBitmaps[aid];
         if r then return r;
         else
         begin
-            r := _wapi.LoadBitmapA2(nil,id);
+            r := _wapi.LoadBitmapA2(nil,aid);
-            FsysBitmaps[id]:= r;
+            FsysBitmaps[aid]:= r;
         end
         return r;
     end
@@ -1516,12 +1521,12 @@ type TcustomIcon = class(TPicturebase)
                 FDestroy := false;
             end else
             begin
-                h := getresourcebyid(r,array("type":"ico"));
+                //h := getresourcebyid(r,array("type":"ico"));
                 if not h then
                 begin
                     if Image then
                     begin
-                        Image.LoadFromFile(r);
+                        Image.LoadFromstr(r);
                         h := Image.tohicon();
                     end
                 end
@@ -1531,13 +1536,13 @@ type TcustomIcon = class(TPicturebase)
         end
     end
     protected
-    class function loadsysico(id);virtual;
+    class function loadsysico(aid);virtual;
     begin
         if not ifarray(FSystemIcons)then FSystemIcons := array();
-        r := FSystemIcons[id];
+        r := FSystemIcons[aid];
         if r then return r;
-        r := _wapi.LoadIconA2(nil,id);
+        r := _wapi.LoadIconA2(nil,aid);
-        FSystemIcons[id]:= r;
+        FSystemIcons[aid]:= r;
         return r;
     end
     function DestroyHandle();virtual;
@@ -1637,6 +1642,7 @@ type TcustomIcon = class(TPicturebase)
     @param(AutoDestroy)(bool) 是否自动是否资源 %%
     **}
 end
+
 type tcustomcursor=class(tcustomicon)
     {**
     @explan(说明)光标类 %%