diff --git a/CommKrnl.dll b/CommKrnl.dll index 37f2325..2f7ffd9 100644 Binary files a/CommKrnl.dll and b/CommKrnl.dll differ diff --git a/MathKrnl.dll b/MathKrnl.dll index 6902d83..ca56e8f 100644 Binary files a/MathKrnl.dll and b/MathKrnl.dll differ diff --git a/TSCrypt.dll b/TSCrypt.dll index a49edc9..c610af0 100644 Binary files a/TSCrypt.dll and b/TSCrypt.dll differ diff --git a/TSLDebugModule.dll b/TSLDebugModule.dll index 997d2b9..03a4cbc 100644 Binary files a/TSLDebugModule.dll and b/TSLDebugModule.dll differ diff --git a/TSLInterp.dll b/TSLInterp.dll index 63a7f9c..13026cf 100644 Binary files a/TSLInterp.dll and b/TSLInterp.dll differ diff --git a/TSLPlugin.dll b/TSLPlugin.dll index fa518fb..896c788 100644 Binary files a/TSLPlugin.dll and b/TSLPlugin.dll differ diff --git a/TSSVRAPI.DLL b/TSSVRAPI.DLL index c974271..f35d7c3 100644 Binary files a/TSSVRAPI.DLL and b/TSSVRAPI.DLL differ diff --git a/designer/teditorform.tsf b/designer/teditorform.tsf index dd56b5a..29a9543 100644 --- a/designer/teditorform.tsf +++ b/designer/teditorform.tsf @@ -758,6 +758,10 @@ type teditorform = class(TVCform) // if not it then return ; if o.Checked then return ; case o.Caption of + c_e_none: + begin + it.currentcodeisnone(); + end c_e_ansi: begin it.CurrentcodeIsAnsi(); diff --git a/designer/utslcodeeditor.tsf b/designer/utslcodeeditor.tsf index a20087a..f54ef0b 100644 --- a/designer/utslcodeeditor.tsf +++ b/designer/utslcodeeditor.tsf @@ -1441,9 +1441,16 @@ type TPageEditerItem=class(TPageItem) FEnCode := "ANSI"; FLastversion := ""; end + function currentcodeisnone(); + begin + if FEnCode="UTF8" then + begin + FEnCode := "None"; + end + end function CurrentCodeIsUtf8(); begin - if FEnCode="ANSI" then + if FEnCode="ANSI" or FEnCode="None" then begin s := FEditer.Text; try diff --git a/funcext/tvclib/cstructurelib.tsf b/funcext/tvclib/cstructurelib.tsf index 17ed889..6e65b00 100644 --- a/funcext/tvclib/cstructurelib.tsf +++ b/funcext/tvclib/cstructurelib.tsf @@ -281,7 +281,7 @@ type ctslctrans = class(tmemoryclass) ret := 1; end end - "short": + "short","word": begin if ifnumber(v)then begin @@ -289,7 +289,7 @@ type ctslctrans = class(tmemoryclass) ret := 1; end end - "shortarray": + "shortarray","wordarray": begin if arraynumberchek(v)and length(v)<= l then begin @@ -570,14 +570,14 @@ type ctslctrans = class(tmemoryclass) o := _objs[i]; o._setcptr_(tptr); end else - if v1="userarray" then + if v="userarray" then begin tptr := ptr+v3; o := _objs[i]; o._setcptr_(tptr); end else begin - _objs[v0]:= ptr+v3; + _objs[i]:= ptr+v3; end end end @@ -657,11 +657,11 @@ type ctslctrans = class(tmemoryclass) begin ret := _tool.readbyte(p); end - "short": + "short","word": begin ret := _tool.readshort(p); end - "shortarray": + "shortarray","wordarray": begin ret := _tool.readshorts(p,l); end @@ -2143,7 +2143,7 @@ begin end function is_validate_type(tp); begin - return array("uint":1,"char":1,"float":1,"double":1,"int":1,"intptr":1,"pointer":1,"int64":1,"byte":1,"short":1,"char*":1,"user*":1,"long":1)[tp]; + return array("uint":1,"char":1,"float":1,"double":1,"int":1,"intptr":1,"pointer":1,"int64":1,"byte":1,"short":1,"char*":1,"user*":1,"long":1,"word":1,"dword":1)[tp]; end function tslarraytocstructcalc(data,alim,bsi,ssize); //计算对其长度 begin @@ -2265,7 +2265,9 @@ begin ret1 := tslarraytocstructcalc(v,alim,npoint,sz); ret[i,2]:= ret1; end else - raise "类型错误"; + begin + raise ("类型错误:" $ tp1); + end ret[i,3]:= npoint; //元素开始的地址 ret[i,4]:= sz; //元素占用空间 ret[i,6]:= size; //元素个数 diff --git a/funcext/tvclib/tcomponent.tsf b/funcext/tvclib/tcomponent.tsf index 9c30506..9feb34d 100644 --- a/funcext/tvclib/tcomponent.tsf +++ b/funcext/tvclib/tcomponent.tsf @@ -61,7 +61,7 @@ uses utslvclauxiliary,UVCPropertyTypesPersistence,utslvclbase; begin if not(o is class(tcomponent))then return array(); t := o.classinfo; - idx := getmsgd_Crc32(tostm(t))+"&&"; + idx := getmsgd_Crc32(tostm(t,0,1))+"&&"; r := GetClassDigestB(idx); if ifarray(r)then return r; r := array(); diff --git a/funcext/tvclib/tcontrol.tsf b/funcext/tvclib/tcontrol.tsf index c6da64a..a9f2038 100644 --- a/funcext/tvclib/tcontrol.tsf +++ b/funcext/tvclib/tcontrol.tsf @@ -297,7 +297,7 @@ type tcontrol = class(tcomponent) } if not(o is class(tcontrol))then return array(); t := o.classinfo; - idx := getmsgd_Crc32(tostm(t))+"%%"; + idx := getmsgd_Crc32(tostm(t,0,1))+"%%"; r := CtlInfoAndDigest(idx); if ifarray(r)then return r; r := array(); diff --git a/funcext/tvclib/utslvcl_com.tsf b/funcext/tvclib/utslvcl_com.tsf index 3fbb970..987e462 100644 --- a/funcext/tvclib/utslvcl_com.tsf +++ b/funcext/tvclib/utslvcl_com.tsf @@ -5,12 +5,13 @@ interface //范例 步骤: //继承 t_com_class - //重写 get_clsid - //重写 get_com_name - //重写 invoke_param_is_excel + //重写 get_clsid clsid 字符串 + //重写 get_com_name 名称 + //重写 invoke_param_is_excel //重写 execute_retun_is_excel - //重写 invoke_call - //重写 install_for_all_users + //重写 invoke_call 调用函数或者属性获取 + //重写 invoke_propertyset 属性设置值 + //重写 install_for_all_users 是否安装给所有用户 //编译成exe //安装 名称.exe -install //卸载 名称.exe -uninstall @@ -36,20 +37,10 @@ interface uses cstructurelib,tslvcl; function sh_get_IShellLinkW(); //获取快捷方式创建接口 function create_short_cutA(targ,lnk);//创建文件快捷方式 -type inukownvtb = class(tslcstructureobj) +type tagELEMDESC_test =class(tagELEMDESC) 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) - ); + inherited; end end type idispatchvtb =class(inukownvtb) @@ -69,6 +60,54 @@ type idispatchvtb =class(inukownvtb) ); 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) @@ -122,6 +161,10 @@ type t_com_class = class() 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; @@ -306,20 +349,122 @@ type t_com_class = class() end function getguid(); begin + global G_CURRENT_CLSID; if not sguid then begin sguid := new tguid(); - sguid.readstr(get_clsid()); + G_CURRENT_CLSID := get_clsid(); + sguid.readstr(G_CURRENT_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; - { +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 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; @@ -371,9 +516,40 @@ type tcom_const = class static const VT_RESERVED = 0x8000; static const VT_ILLEGAL = 0xffff; static const VT_ILLEGALMASKED = 0xfff; - static const VT_TYPEMASK = 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 DISP_E_EXCEPTION=0x80020009L; + static const S_OK = 0; +end +type tcom_const = class(tagTYPEKIND,tagDESCKIND,tagTYPEFLAGS, + tagFUNCFLAGS,tagVARFLAGS, + tagFUNCKIND,tagCALLCONV,tagINVOKEKIND,tagVARKIND, + tagvtype,tagwinerr) + ////// + /////////////////////////// + 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) @@ -467,45 +643,355 @@ type tguid=class(tslcstructureobj) return r; end end - -type tagVARIANT =class(tslcstructureobj) - private - class function getstruct() +type inukownvtb = class(tslcstructureobj) + function create(ptr); begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + 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",10), //指示此结构描述的接口上的函数数目。 + ("cVars","short",10), //指示此结构所描述的接口上的变量和数据字段的数目。 + ("cImplTypes","short",100), //指示此结构描述的接口上实现的接口的数量。 + ("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 + 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) - ) ); - return SSTRUCT; - end - public - function create(ptr) - begin - inherited create(getstruct(),ptr); - end -end -type tagDISPPARAMS = class(tslcstructureobj) + end + property llVal index "data" read _getvalue_ write _setvalue_; private - class function getstruct() + function getdataaddr(); //获取地址 begin - if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + 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) - ) ); - return SSTRUCT; - end - public + end function create(ptr) begin - inherited create(getstruct(),ptr); + stc := static MemoryAlignmentCalculate(DISPPARAMS_Stc()); + inherited create(stc,ptr); end function getarg(idx); begin @@ -550,28 +1036,19 @@ type tagDISPPARAMS = class(tslcstructureobj) 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); + stc := static MemoryAlignmentCalculate(array( + ("ptr","intptr",0) + ) + ); + inherited create(stc,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; + return wideptrtoansi(p); end end //////////////////////////vtb///////////////////////////// @@ -595,6 +1072,46 @@ type inukownvtbcontainer = class(tslcstructureobj) 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 @@ -650,12 +1167,54 @@ type iunkown =class(tcom_const) function _getptr_(); begin return fvtablecontainer._getptr_(); - end + 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 - type idispatch=class(iunkown) protected - static IID_IDispatch; + static IID_IDispatch; + ftypeinfo; function createvtb(ptr);override; begin return new idispatchvtb(ptr); @@ -677,41 +1236,65 @@ type idispatch=class(iunkown) 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 + begin + //echo "\r\n>>>>>>idispatch:",functionname(1); pctinfo := 0; - return 0; + return 1; end function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual; begin - if ppTInfo then ppTInfo := 0; + //echo "\r\n>>>>>>idispatch:",functionname(1),iTInfo," ",lcid," ",ppTInfo; + return E_NOTIMPL; + if not ftypeinfo then + begin + ftypeinfo := new ITypeInfo(); + end + ppTInfo := ftypeinfo._getptr_(); + echo "====",ppTInfo; + return S_OK; return E_NOTIMPL; 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; if cnames>1 then return E_INVALIDARG; - ostr := new tptrarray(rgszNames); - rgDispId := getdispid(ostr.ansistr); - return 0; + ostr := new tptrarray(rgszNames); + rgDispId := get_func_str_id(ostr.ansistr); + return S_OK; 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 + //echo "\r\n>>>>>>idispatch:",functionname(1)," ",dispIdMember," ",wFlags," ",pVarResult," err:",pExcepInfo; + fname := get_func_id_str(dispIdMember); + if wFlags=2 then 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)); + FInvokename := fname; + if pVarResult then + begin + //AddRef(s); + 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 0; + end else + if wFlags = 4 then + begin + fcom_mgr.invoke_propertyset(fname,trans_params(pDispParams)[0]); + end return 0; end function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual; @@ -727,30 +1310,320 @@ type idispatch=class(iunkown) function release(s:pointer):integer;stdcall;override; begin r := inherited; - if r=0 and fcom_mgr then fcom_mgr.stop_run(); + if r=0 and fcom_mgr then + begin + fcom_mgr.stop_run(); + end return r; - end - private - frgDispIds; - frgDispIds2; - fglobalL; - function getdispid(s); + end + private + function trans_params(pDispParams); begin - id := frgDispIds[s]; - if id>0 then + o := new tagDISPPARAMS(pDispParams); + pp := o.getArgs(); + pms := array(); + for idx,p1 in pp do begin - return id; - end - id := length(frgDispIds); - frgDispIds2[id] := s; - frgDispIds[s] := id; - end - function getdispidstr(id); - begin - return frgDispIds2[id]; + 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 + 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 + 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(); + global G_CURRENT_CLSID; + ftypeattr.guidobj().readstr(G_CURRENT_CLSID); + end + pptypeattr := ftypeattr._getptr_(); + return S_OK; + //return E_NOTIMPL; + 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 0; + //return E_NOTIMPL; + 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); + ppFuncDesc := fFuncDesc._getptr_(); + return S_OK; + end + fFuncDesc; + function GetVarDesc(sf:pointer;index:integer;var ppFuncDesc:pointer):integer;stdcall;virtual; + begin + echo "\r\n===ITypeInfo:",functionname(1); + //return E_NOTIMPL; + end + function GetNames(sf:pointer;memid:integer;rgBstrNames:pointer;cMaxNames:integer;var pcNames:integer):integer;stdcall;virtual; //处理命名参数问题 + begin + echo "\r\n===ITypeInfo:",functionname(1)," ",memid," ",rgBstrNames," ",cMaxNames," ",pcNames; + return E_NOTIMPL; + 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; + end + function GetDocumentation():integer;stdcall;virtual; + begin + echo "\r\n===ITypeInfo:",functionname(1); + return E_NOTIMPL; + end + function GetDllEntry():integer;stdcall;virtual; + begin + echo "\r\n===ITypeInfo:",functionname(1); + return E_NOTIMPL; + end + function GetRefTypeInfo(sf:pointer;hRefType:integer;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; + begin + echo "\r\n===ITypeInfo:",functionname(1); + return E_NOTIMPL; + end + function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;// + begin + echo "\r\n===ITypeInfo:",functionname(1); + end + function GetMops(sf:pointer;memid:integer;pBstrMops:pointer):integer;stdcall;virtual; + begin + echo "\r\n===ITypeInfo:",functionname(1); + return E_NOTIMPL; + end + function GetContainingTypeLib(sf:pointer;ppTLib:pointer;var pIndex:integer):integer;stdcall;virtual; + begin + echo "\r\n===ITypeInfo:",functionname(1); + return E_NOTIMPL; + end + procedure ReleaseTypeAttr(sf:pointer;pTypeAttr:pointer);stdcall;virtual; + begin + echo "\r\n===ITypeInfo:",functionname(1)," ",sf; + 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 + 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 + 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 + 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 @@ -1027,20 +1900,45 @@ begin 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 + 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 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"; +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"; + 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"; initialization end. \ No newline at end of file diff --git a/funcext/tvclib/utslvclauxiliary.tsf b/funcext/tvclib/utslvclauxiliary.tsf index 9d13517..b671859 100644 --- a/funcext/tvclib/utslvclauxiliary.tsf +++ b/funcext/tvclib/utslvclauxiliary.tsf @@ -51,6 +51,7 @@ function TS_ExecPath():string; function TS_GetAppPath():string; function TS_GetIniPath(t:integer;iname:string):string; function gettslexefullpath(); +function int_to_binary(d,n); //整数转换成字符串 //function tsl_str_head_at(s,n); function get_tsl_mem_ptr(s,n); type tuiglobaldata=class() //全局对象存储 @@ -3626,7 +3627,7 @@ begin @return(string) 16进制字符串 %% **} r := ""; - str := tostm(t); + str := tostm(t,0,1); ky := static(inttostr(0 -> 9)union array("A","B","C","D","E","F")); idx := 1; setlength(r,length(str)* 2); @@ -3994,6 +3995,31 @@ function TS_ModulePath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$ function TS_ExecPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath"; function TS_GetAppPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetAppPath"; function TS_GetIniPath(t:integer;iname:string):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetIniPath"; +function int_to_binary(d,n); //整数转换成字符串 +begin + r := ""; + x := d; + ct := 0; + if not(n>1)then n := 8; + while x>0 do + begin + divmod(x,2,a,b); + r := inttostr(b)+r; + x := a; + ct++; + if ct >= n then break; + end + if ct=0 then + begin + ct := 1; + r := "0"; + end + for i := ct to n-1 do + begin + r := "0"+r; + end + return r; +end function istextascii(s); //ansi编码 begin len := length(s); diff --git a/funcext/tvclib/utvclgraphics.tsf b/funcext/tvclib/utvclgraphics.tsf index 2a7c5b2..19db048 100644 --- a/funcext/tvclib/utvclgraphics.tsf +++ b/funcext/tvclib/utvclgraphics.tsf @@ -1480,9 +1480,10 @@ type tg_axes = class(tg_base) // begin return ; end - function gs_auto_ticks(idx,v);//自动更新坐标标签 + function gs_auto_ticks(vidx,v);//自动更新坐标标签 begin tg_boolen_value(v,nv); + idx := tg_get_true_idx(vidx); if nv=tgc_on or nv=tgc_off then begin if idx in array(0,1,2) then @@ -1501,8 +1502,9 @@ type tg_axes = class(tg_base) // return fauto_ticks; end end - function get_axises(idx); + function get_axises(vidx); begin + idx := tg_get_true_idx(vidx); if idx in array(0,1,2) then begin return faxes_objects[idx]; @@ -1524,8 +1526,9 @@ type tg_axes = class(tg_base) // return faxes_bounds; end end - function gs_data_bounds(idx,v); + function gs_data_bounds(vidx,v); begin + idx := tg_get_true_idx(vidx); if v=-1 then begin if idx in array(0,1,2) then @@ -1547,8 +1550,9 @@ type tg_axes = class(tg_base) // return fdata_bounds; end end - function gs_zoom_box(idx,v); + function gs_zoom_box(vidx,v); begin + idx := tg_get_true_idx(vidx); if ifarray(v) and ifnumber(v[0]) and ifnumber(v[1]) then begin if idx in array(0,1,2) then @@ -1562,9 +1566,10 @@ type tg_axes = class(tg_base) // return fzoom_box; end end - function gs_axes_reverse(idx,v); //反向 + function gs_axes_reverse(vidx,v); //反向 begin if not tg_boolen_value(v,nv) then return ; + idx := tg_get_true_idx(vidx); if nv=tgc_off or nv=tgc_on then begin if idx in array(0,1) then @@ -1594,8 +1599,9 @@ type tg_axes = class(tg_base) // return fmargins; end end - function gs_sub_ticks(idx,v); //小刻度线 + function gs_sub_ticks(vidx,v); //小刻度线 begin + idx := tg_get_true_idx(vidx); if ifnumber(v) and (v>=0) then begin if idx in array(0,1,2) then @@ -3449,6 +3455,10 @@ type tg_base = class(TNode,tg_const) // vi := GetNodeByIndex(i); vi.paint(cvs); end + end + function hit_at(xy);virtual; + begin + return false; end function set_lineinfo_to_canvas(cvs,info); begin @@ -3485,7 +3495,19 @@ type tg_base = class(TNode,tg_const) // cvs.font.bkcolor := fi.bkcolor; cvs.font.width := fi.size; cvs.font.height := fi.size*2; + end + function addEventListener(evtype,fn,ifCapture); + begin + + end + function removeEventListener(evtype,fn,ifCapture); + begin + end + function dispatchEvent(evt); //分发 + begin + + end published property line_mode read fline_mode write set_line_mode; property mark_mode read fmark_mode write set_mark_mode; @@ -3657,9 +3679,110 @@ type tg_const = class() //static const tgc_out_lower_left = "out_lower_left"; ////////////// end +type tg_evt =class() //消息 + function create(etype,pms); + begin + feventtype := etype; + ftimeStamp := mtic; + fisTrusted := false; + feventPhase := 0; + freturnValue := true; + fdefaultPrevented := false; + fbubbles := true; + FstopImmediatePropagationed := false; + if not ifarray(pms) then return ; + fiparams := pms; + fisTrusted := pms["istrusted"]?true:false; + ftarget := pms["target"]; + fcurrentTarget := pms["currenttarget"]; + fbubbles := pms["bubbles"]?true:false; + feventPhase := (pms["eventphase"]>0)?pms["eventphase"]:0; + end + function preventdefault(); + begin + fdefaultPrevented := true; + end + function stoppropagation(); + begin + fstoppropagationed := true; + end + function composedPath();//从触发元素到最外层Window + begin + return array(); + end + function stopImmediatePropagation(); + begin + FstopImmediatePropagationed := true; + end + published + property bubbles read fbubbles; //是否冒泡,只读 + property currentTarget read fcurrentTarget;//当前绑定的对象,只读 + property target read ftarget;//目标对象,只读 + property stoppropagationed read fstoppropagationed;//是否已经调用 stoppropagation,只读 + property defaultPrevented read fdefaultPrevented;//是否已经调用 preventdefault,只读 + property returnValue read freturnValue write freturnValue;//true表示正常执行,false表示阻止默认行为 + property eventPhase read feventPhase;//只读,0,1,捕获,2到达目标,3,冒泡 + property timeStamp read ftimeStamp;//只读,加载完成到现在的时间 + property eventtype read feventtype;//只读类型 + property isTrusted read fisTrusted;//true表示用户触发,false表示代码触发 + property init_params read fiparams; //初始化参数 + private + feventtype; + ftimeStamp; + fisTrusted; + feventPhase; + freturnValue; + fdefaultPrevented; + fstoppropagationed; + ftarget; + fbubbles; + fcurrentTarget; + FstopImmediatePropagationed; + fiparams; +end +type tg_evt_mouse = class(tg_evt) //鼠标消息 + function create(etyp,pms); + begin + inherited; + if ifarray(pms) then + begin + fcvsx := pms["cvsx"]; + fcvsy := pms["cvsy"]; + end + end + property cvsx read fcvsx; + property cvsy read fcvsy; + private + fcvsx; + fcvsy; +end +type tg_evt_custom = class(tg_evt) //自定义消息 + function create(etyp,pms); + begin + inherited; + fdetail := array(); + if ifarray(pms) then fdetail := pms["detail"]; + end + property detail read fdetail; + private + fdetail; +end implementation - - +function node_hit_at(nd,info); //命中处理 +begin + if not(nd.visible) then return 0; + nct := nd.NodeCount; + if nct>0 then + begin + for i := nd.NodeCount-1 downto 0 do + begin + hnod := node_hit_at(nd.GetNodeByIndex(i),info) ; + if hnod then return hnod; + end + end + if nd.hit_at(info) then return nd; + return 0; +end function mg_bds(bds,d); //合并数据上下界 begin d[0,0] := min(bds[0,0],d[0,0]); @@ -4091,6 +4214,16 @@ function rec_to_points(rec); begin return array(rec[array(0,1)],rec[array(2,1)],rec[array(2,3)],rec[array(0,3)],rec[array(0,1)]); end +function tg_get_true_idx(idx); +begin + nidx := idx; + case idx of + "x","X": nidx := 0; + "y","Y": nidx := 1; + "z","Z": nidx := 2; + end ; + return nidx; +end //////////////////////////////////////// initialization finalization diff --git a/funcext/tvclib/uwindowsinterface.tsf b/funcext/tvclib/uwindowsinterface.tsf index ddd916e..1ffcf27 100644 --- a/funcext/tvclib/uwindowsinterface.tsf +++ b/funcext/tvclib/uwindowsinterface.tsf @@ -666,9 +666,9 @@ type twindowsapi = class() function ImageList_ReplaceIcon(himl:pointer;i:integer;hicon:pointer):integer;stdcall;external "Comctl32.dll" name "ImageList_ReplaceIcon"; function ImageList_SetIconSize(himl:pointer;cx:integer;cy:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_SetIconSize"; function ImageList_GetIconSize(himl:pointer;var cx:integer;var cy:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_GetIconSize"; - function ImageList_GetIcon(himl:pointer;i:integer;flags:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_GetIcon"; - function ImageList_DrawIndirect(pimldp:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_DrawIndirect"; - function ImageList_DragShowNolock(fShow:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragShowNolock"; + function ImageList_GetIcon(himl:pointer;i:integer;flags:integer):pointer;stdcall;external "Comctl32.dll" name "ImageList_GetIcon"; + function ImageList_DrawIndirect(pimldp:pointer):pointer;stdcall;external "Comctl32.dll" name "ImageList_DrawIndirect"; + function ImageList_DragShowNolock(fShow:integer):integer;stdcall;external "Comctl32.dll" name "ImageList_DragShowNolock"; function InitCommonControlsEx(it:pointer):integer;stdcall;external "Comctl32.dll" name "InitCommonControlsEx"; function Comctl32DllGetVersion(it:pointer):pointer;stdcall;external "Comctl32.dll" name "DllGetVersion"; function GetOpenFileNameA(LPOPENFILENAMEA:pointer):integer;stdcall;external "Comdlg32.dll" name "GetOpenFileNameA" keepresident; diff --git a/plugin/TSLCPLUGIN.DLL b/plugin/TSLCPLUGIN.DLL index e2e1283..9478ba6 100644 Binary files a/plugin/TSLCPLUGIN.DLL and b/plugin/TSLCPLUGIN.DLL differ diff --git a/plugin/TSLClient.dll b/plugin/TSLClient.dll index 7b9f0f4..f38ab01 100644 Binary files a/plugin/TSLClient.dll and b/plugin/TSLClient.dll differ diff --git a/plugin/TSSecurity.dll b/plugin/TSSecurity.dll index 809db6d..07f45ff 100644 Binary files a/plugin/TSSecurity.dll and b/plugin/TSSecurity.dll differ diff --git a/plugin/office_plugin.DLL b/plugin/office_plugin.DLL index 1e218c6..c9f6ac0 100644 Binary files a/plugin/office_plugin.DLL and b/plugin/office_plugin.DLL differ diff --git a/protocol.dll b/protocol.dll index e789fb6..07d72ca 100644 Binary files a/protocol.dll and b/protocol.dll differ diff --git a/tsjni.dll b/tsjni.dll index a553ac3..a3bdf37 100644 Binary files a/tsjni.dll and b/tsjni.dll differ diff --git a/tsleditor.exe b/tsleditor.exe index a349047..96d531b 100644 Binary files a/tsleditor.exe and b/tsleditor.exe differ diff --git a/tslkrnl.dll b/tslkrnl.dll index 67e4524..060213e 100644 Binary files a/tslkrnl.dll and b/tslkrnl.dll differ diff --git a/tslpcre.dll b/tslpcre.dll index 694b647..e74cb87 100644 Binary files a/tslpcre.dll and b/tslpcre.dll differ diff --git a/tsnet.dll b/tsnet.dll index 024e22e..84729e4 100644 Binary files a/tsnet.dll and b/tsnet.dll differ diff --git a/whatsnew.txt b/whatsnew.txt index 2ec300c..28cff9b 100644 --- a/whatsnew.txt +++ b/whatsnew.txt @@ -1,3 +1,28 @@ +更新日志--------2024-06-02 + 修正：officeplugin的问题。 + 修正：数据库连接采用JDBC驱动时在无主键sqltable插入时数据异常时的问题。 + 升级：支持超大流的存在，支持tostm(x,0,2)模式（超级大流的紧缩模式），即允许超过1.9G模式。 + 升级：新增超长binary类型，该类型目前仅在流生成以及流的文件写入等提供支持。新一代客户端提供对超长binary的支持。 + 升级：支持超大结果集的返回以及超大执行体的执行（包含网格）。 + 原有的最大流设定依旧生效，且作为缺省值，FileMgr.ini中新增如下设定覆盖该设定： +[FileMgr Config] +StrmLimited=19000 +;缺省值，单位为M +[Strm Limited] +user1=20480 +;指定用户，单位为M +;如需要32位和64位问题，则可同时支持StrmLimited64和Strm Limited64来区分64位版本的独立设定。当前由于32位支持暂未继续支持新版本已无必要，但代码仍保留支持。 + 升级：平台用户可以自主设定流的最大限额，终端用户的流限额保持原有不变。 + +更新日志--------2024-05-17 + 升级：MATLAB 支持包，将采用matlab.dll.202xx来支持使用包括R2017b以上及各种未来新MATLAB版本，避免对新版本支持的升级。 + +更新日志--------2024-05-16 + 升级：MATLAB 2024a及以上支持包，将采用matlab.dll.202xx来支持使用各种未来新MATLAB版本，避免对新版本支持的升级。 + +更新日志--------2024-04-30 + 修订：04-26日版本修复，JDBC连接模式的功能Execsql执行中如果发生错误，将错误信息返回给输出结果集参数。 + 更新日志--------2024-04-26 修订：JDBC连接模式的功能 增加对ftBytes的支持 @@ -5,6 +30,8 @@ Execsql执行中如果发生错误，将错误信息返回给result参数 TS-SQL和ExecSql执行中如果发生错误，在TSL日志中增加连接串别名和SQL 修订：SQLBeginTrans函数实现层支持JDBC连接模式options + 升级：tslsvr.ini增加CQ_MARKET的设置，允许配置哪些市场需要除权 + 修正：event -job命令可能崩溃的问题 更新日志--------2024-04-25 修订：特殊错误表达式导致的问题（正常使用不受影响）。