tsl64

更新动态库

funcext/tvclib/utslvcl_com.tsf

@@ -34,7 +34,7 @@ interface
         end
     end 
 *)
-uses  cstructurelib,tslvcl;
+uses  cstructurelib,utslvclauxiliary,tslvcl;
 function sh_get_IShellLinkW(); //获取快捷方式创建接口
 function create_short_cutA(targ,lnk);//创建文件快捷方式
 type tagELEMDESC_test =class(tagELEMDESC)
@@ -156,6 +156,10 @@ type t_com_class = class()
     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
@@ -349,12 +353,10 @@ type t_com_class = class()
 	   end 
 	   function getguid();
 	   begin
-	       global G_CURRENT_CLSID;
 	       if not sguid then 
 	       begin 
 	           sguid := new tguid();
-	           G_CURRENT_CLSID := get_clsid();
+	           sguid.readstr(get_clsid());
-	           sguid.readstr(G_CURRENT_CLSID);
 	       end 
 	       return sguid;
 	   end 
@@ -451,6 +453,16 @@ type tagFUNCKIND = class
     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;
@@ -529,14 +541,83 @@ type tagwinerr =class
     static const E_ABORT=0x80004004L;
     static const E_FAIL=0x80004005L;
     static const E_ACCESSDENIED=0x80070005L;
-    
-    static const DISP_E_EXCEPTION=0x80020009L;
     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,tagVARKIND,
+                        tagFUNCKIND,tagCALLCONV,tagINVOKEKIND,DISPID_TYPE,tagVARKIND,
-                        tagvtype,tagwinerr)
+                        tagvtype,tagwinerr,FACILITY_DISPATCH)
     //////    
     ///////////////////////////
     static const IMPLTYPEFLAG_FDEFAULT = 1;
@@ -544,7 +625,6 @@ type tcom_const = class(tagTYPEKIND,tagDESCKIND,tagTYPEFLAGS,
     static const IMPLTYPEFLAG_FRESTRICTED = 4;
     static const IMPLTYPEFLAG_FDEFAULTVTABLE = 8;    
     ////////////////////////////////
-
     ////////////////    
     static const DISPATCH_METHOD = 0x1; 
     static const DISPATCH_PROPERTYGET = 0x2;
@@ -922,9 +1002,9 @@ type tagTYPEATTR = class(tcom_stc_base)
                 ("lpstrSchema","intptr",0), 
                 ("cbSizeInstance","int",0), //此类型的实例的大小。
                 ("typekind","int",4),     //TYPEKIND 值描述此信息所描述的类型。//TKIND_DISPATCH
-                ("cFuncs","short",10), //指示此结构描述的接口上的函数数目。
+                ("cFuncs","short",1), //指示此结构描述的接口上的函数数目。
-                ("cVars","short",10),   //指示此结构所描述的接口上的变量和数据字段的数目。  
+                ("cVars","short",0),   //指示此结构所描述的接口上的变量和数据字段的数目。  
-                ("cImplTypes","short",100), //指示此结构描述的接口上实现的接口的数量。
+                ("cImplTypes","short",0), //指示此结构描述的接口上实现的接口的数量。
                 ("cbSizeVft","short",0), //	此类型的虚拟方法表 (VTBL) 的大小。
                 ("cbAlignment","short",8),  //指定此类型实例的字节对齐方式。
                 ("wTypeFlags","short",TYPEFLAG_FDISPATCHABLE),   //tagTYPEFLAGS
@@ -933,9 +1013,9 @@ type tagTYPEATTR = class(tcom_stc_base)
                 ("tdescAlias","user",class(tagTYPEDESC).TYPEDESC_stc),
                 ("idldescType","user",class(tagIDLDESC).IDLDESC_stc)                
                 );
-    end 
+    end     
-    
     public
+    property cFuncs index "cFuncs" read _getvalue_ write _setvalue_;
     function guidobj();
     begin
         ptr := _getvalueaddr2_("guid");
@@ -993,6 +1073,17 @@ type tagDISPPARAMS = class(tcom_stc_base)
         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 
@@ -1045,9 +1136,13 @@ type tptrarray =class(tslcstructureobj)
                 );
         inherited create(stc,ptr);
     end
-    function ansistr();
+    function ansistr(idx);
     begin
-        p := _getvalue_("ptr");
+        if idx>0 then 
+        begin 
+            p := mtool().readptr( int64(_getptr_()+idx*8));
+        end else 
+            p := _getvalue_("ptr");
         return wideptrtoansi(p);
     end 
 end 
@@ -1145,7 +1240,8 @@ type iunkown =class(tcom_const)
         end 
     end     
     function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
-    begin   
+    begin  
+        ppv := 0; 
         if IID_IUnknown.equ(riid) then 
         begin 
             ppv  := _getptr_();
@@ -1211,6 +1307,11 @@ type func_mid_cache = class
     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;
@@ -1223,6 +1324,7 @@ type idispatch=class(iunkown)
     [weakref] fcom_mgr;
     function create(ptr)
     begin
+        
         inherited ;//create(getstruct(),ptr);
         if not IID_IDispatch then 
         begin
@@ -1230,40 +1332,60 @@ type idispatch=class(iunkown)
             IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");        
         end 
         if not ptr then 
-        begin          
+        begin  
+                   
             fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));           
-            fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));           
+            fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo))); 
-            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));           
+            fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));            
-            fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));           
+            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 
-        //echo "\r\n>>>>>>idispatch:",functionname(1);
+        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 := new ITypeInfo();  
+            ftypeinfo.fcom_mgr := fcom_mgr;              
         end    
         ppTInfo := ftypeinfo._getptr_();
-        echo "====",ppTInfo;
         return S_OK;
-        return E_NOTIMPL;
+        //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),"  ",lcid,"   ",cNames;
+        //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); 
+        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;
@@ -1275,7 +1397,6 @@ type idispatch=class(iunkown)
             FInvokename := fname;
             if pVarResult then 
             begin 
-                //AddRef(s);
                 rv := new tagVARIANT( pVarResult);
                 rv._setvalue_("vt" , VT_DISPATCH);
                 rv._setvalue_("data",s);
@@ -1289,16 +1410,18 @@ type idispatch=class(iunkown)
             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 0;
+            return S_OK;
         end else 
-        if wFlags = 4 then 
+        if (wFlags .& 4) or (wFlags .& 8)  then 
         begin 
             fcom_mgr.invoke_propertyset(fname,trans_params(pDispParams)[0]);    
         end 
-        return 0;
+        return S_OK;
+        //////////////返回很多错误类型//////
     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        
+    begin   
+        ppv := 0;             
         if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then 
         begin 
             ppv  := _getptr_();
@@ -1316,10 +1439,16 @@ type idispatch=class(iunkown)
         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);
+        o := new tagDISPPARAMS(pDispParams);        
+        //echo "\r\ncnamecout:",tostn(o.getcnameargs());
         pp := o.getArgs();
         pms := array();       
         for idx,p1 in pp do 
@@ -1341,6 +1470,7 @@ type ITypeInfo=class(iunkown)
         return new ITypeInfoVtbl(ptr);
     end 
     public 
+    [weakref] fcom_mgr;
     function create(ptr)
     begin
         nptr := not ptr;
@@ -1377,6 +1507,7 @@ type ITypeInfo=class(iunkown)
     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_();
@@ -1404,12 +1535,13 @@ type ITypeInfo=class(iunkown)
         if ifnil(ftypeattr) then 
         begin
             ftypeattr := new tagTYPEATTR();
-            global G_CURRENT_CLSID;
+            ftypeattr.guidobj().readstr(fcom_mgr.get_clsid());
-            ftypeattr.guidobj().readstr(G_CURRENT_CLSID);
+            ns := fcom_mgr.method_names();
+            if ifarray(ns) then ftypeattr.cFuncs := length(ns) ;
         end 
         pptypeattr := ftypeattr._getptr_();
         return S_OK;
-        //return E_NOTIMPL;      
+        //return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;      
     end 
     function GetTypeComp(sf:pointer;var ppTComp:pointer):integer;stdcall;virtual;
     begin
@@ -1420,33 +1552,36 @@ type ITypeInfo=class(iunkown)
             fITypecomp.fitypeinfo := sf; 
         end 
         ppTComp := fITypecomp._getptr_();
-        return 0;
+        return S_OK;
-        //return E_NOTIMPL;      
+        //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);
+        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 ppFuncDesc:pointer):integer;stdcall;virtual;
+    function GetVarDesc(sf:pointer;index:integer;var ppVarDesc:pointer):integer;stdcall;virtual;
     begin
         echo "\r\n===ITypeInfo:",functionname(1);   
-        //return E_NOTIMPL;      
+        return E_NOTIMPL;  
+        //return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;     
     end 
-    function GetNames(sf:pointer;memid:integer;rgBstrNames:pointer;cMaxNames:integer;var pcNames:integer):integer;stdcall;virtual;  //处理命名参数问题
+    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_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;          
+        return E_NOTIMPL;          
     end 
     function GetImplTypeFlags(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual;
     begin
@@ -1462,53 +1597,67 @@ type ITypeInfo=class(iunkown)
                     pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
     begin  
          echo "\r\n===ITypeInfo:",functionname(1);   
-         return E_NOTIMPL;         
+         return E_NOTIMPL; 
+         //return DISP_E_EXCEPTION  E_INVALIDARG   S_OK;     
     end
-    function GetDocumentation():integer;stdcall;virtual;
+    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():integer;stdcall;virtual;
+    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);
-        return E_NOTIMPL; 
+        pbstrdllname := 0;
+        pbstrname := 0;
+        pwordinal := 0;
+        return S_OK;
+        //return E_INVALIDARG,E_OUTOFMEMORY; 
     end  
-    function GetRefTypeInfo(sf:pointer;hRefType:integer;ITypeInfo:pointer):integer;stdcall;virtual;
+    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;ppv:pointer):integer;stdcall;virtual;
+    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;pBstrMops:pointer):integer;stdcall;virtual;
+    function GetMops(sf:pointer;memid:integer;var pBstrMops:pointer):integer;stdcall;virtual;
     begin
         echo "\r\n===ITypeInfo:",functionname(1);
-        return E_NOTIMPL; 
+        pBstrMops := 0;
+        return S_OK; 
     end 
-    function GetContainingTypeLib(sf:pointer;ppTLib:pointer;var pIndex:integer):integer;stdcall;virtual;
+    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;
+        //pTypeAttr := 0;
-        //ftypeattr := nil;
     end 
     procedure ReleaseFuncDesc(sf:pointer;pFuncDesc:pointer);stdcall;virtual;
     begin
         echo "\r\n===ITypeInfo:",functionname(1);
         //pFuncDesc := 0;
-        //fFuncDesc := nil;
     end 
     procedure ReleaseVarDesc(sf:pointer;pVarDesc:pointer);stdcall;virtual;
     begin
@@ -1516,8 +1665,7 @@ type ITypeInfo=class(iunkown)
     end 
     private 
     ftypeattr;
-    fITypecomp;
+    fITypecomp;    
-    
 end
 function get_funcs_info();
 begin
@@ -1534,6 +1682,7 @@ type ITypecomp=class(iunkown)
         return new ITypecompVtbl(ptr);
     end 
     public 
+    [weakref] fcom_mgr;
     function create(ptr)
     begin
         nptr := not ptr;
@@ -1552,6 +1701,7 @@ type ITypecomp=class(iunkown)
     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_();
@@ -1651,6 +1801,7 @@ type IClassFactory=class(iunkown)
     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_();
@@ -1912,6 +2063,9 @@ 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 
@@ -1925,9 +2079,26 @@ begin
     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(var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRevokeClassObject";
+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";
@@ -1940,5 +2111,8 @@ function WideCharToMultiByte(CodePage:integer;dwFlags:integer;lpWideCharStr:poin
 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.

funcext/tvclib/utslvclauxiliary.tsf

@@ -1653,7 +1653,7 @@ type TNode = class() //
         bidx := idx0;
         for i,it in its do
         begin
-            if(it is class(TNode))and(not it.Parent)then
+            if node_insert_check(it) then
             begin
                 FItems.InsertBefor(it,idx0);
                 FCurrentAddNode := it;
@@ -1670,7 +1670,7 @@ type TNode = class() //
         @param(it)(TNode) ×Ö·û´® %%
         @param(idx)(integer) ÐòºÅ ĬÈÏΪ0 %%
         **}
-        if(it is class(TNode))and(not it.Parent)then
+        if node_insert_check(it) then
         begin
             if idx<0 then idx := 0;
             if idx>FItems.Count then idx := FItems.Count;
@@ -1682,6 +1682,10 @@ type TNode = class() //
             return true;
         end
     end
+    function node_insert_check(it);virtual;
+    begin
+        return (it is class(TNode))and(not it.Parent);
+    end 
     function Expand();virtual; //Õ¹¿ª
     begin
         FExpanded := true;
@@ -4317,6 +4321,10 @@ end
 function get_tsl_mem_ptr(s,n);
 begin
     ptr := static makeinstance(thisfunction(get_tsl_ptr_drift));
+    if ifwstring(s) then 
+    begin
+        _f_ := static function(var v:widestring;n:integer):pointer;cdecl;external ptr;
+    end else 
     if ifstring(s) then 
     begin 
         _f_ := static function(var v:string;n:integer):pointer;cdecl;external ptr;

whatsnew.txt

@@ -1,3 +1,6 @@
+更新日志--------2024-06-11
+                  修正：启用的新的流格式存在诱发崩溃的问题。
+
 更新日志--------2024-06-02
                   修正：officeplugin的问题。
                   修正：数据库连接采用JDBC驱动时在无主键sqltable插入时数据异常时的问题。