diff --git a/MathKrnl.dll b/MathKrnl.dll index ca56e8f..9e7e018 100644 Binary files a/MathKrnl.dll and b/MathKrnl.dll differ diff --git a/PK_SQL.DLL b/PK_SQL.DLL new file mode 100644 index 0000000..54f6b47 Binary files /dev/null and b/PK_SQL.DLL differ diff --git a/PK_SQL_MYSQL.DLL b/PK_SQL_MYSQL.DLL new file mode 100644 index 0000000..d5afcdc Binary files /dev/null and b/PK_SQL_MYSQL.DLL differ diff --git a/PK_SQL_ODBC.DLL b/PK_SQL_ODBC.DLL new file mode 100644 index 0000000..6d1fb6a Binary files /dev/null and b/PK_SQL_ODBC.DLL differ diff --git a/PK_SQL_POSTGRESQL.DLL b/PK_SQL_POSTGRESQL.DLL new file mode 100644 index 0000000..3a779ae Binary files /dev/null and b/PK_SQL_POSTGRESQL.DLL differ diff --git a/TSLInterp.dll b/TSLInterp.dll index 13026cf..7b537f3 100644 Binary files a/TSLInterp.dll and b/TSLInterp.dll differ diff --git a/funcext/tvclib/utslvcl_com.tsf b/funcext/tvclib/utslvcl_com.tsf index 987e462..a61b49a 100644 --- a/funcext/tvclib/utslvcl_com.tsf +++ b/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(G_CURRENT_CLSID); + sguid.readstr(get_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, - tagvtype,tagwinerr) + tagFUNCKIND,tagCALLCONV,tagINVOKEKIND,DISPID_TYPE,tagVARKIND, + 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), //指示此结构描述的接口上的函数数目。 - ("cVars","short",10), //指示此结构所描述的接口上的变量和数据字段的数目。 - ("cImplTypes","short",100), //指示此结构描述的接口上实现的接口的数量。 + ("cFuncs","short",1), //指示此结构描述的接口上的函数数目。 + ("cVars","short",0), //指示此结构所描述的接口上的变量和数据字段的数目。 + ("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_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames))); - fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_))); + fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo))); + fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames))); + fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_))); + //echo tostn(fvtable._getdata_); end fglobalL := TS_GetGlobalL(); end function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual; begin - //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; - begin + function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override; + begin + ppv := 0; if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then begin ppv := _getptr_(); @@ -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(G_CURRENT_CLSID); + ftypeattr.guidobj().readstr(fcom_mgr.get_clsid()); + ns := fcom_mgr.method_names(); + if ifarray(ns) then ftypeattr.cFuncs := length(ns) ; end pptypeattr := ftypeattr._getptr_(); return S_OK; - //return E_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 E_NOTIMPL; + return S_OK; + //return E_INVALIDARG ,E_OUTOFMEMORY,S_OK; end function GetFuncDesc(sf:pointer;idx:integer;var ppFuncDesc:pointer):integer;stdcall;virtual; begin echo "\r\n===ITypeInfo:",functionname(1)," ",idx," ",ppFuncDesc; //return E_NOTIMPL; if not fFuncDesc then fFuncDesc := get_funcs_info(); - fFuncDesc._setvalue_("memid",idx); + 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; - //ftypeattr := nil; + //pTypeAttr := 0; 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. \ No newline at end of file diff --git a/funcext/tvclib/utslvclauxiliary.tsf b/funcext/tvclib/utslvclauxiliary.tsf index b671859..024f564 100644 --- a/funcext/tvclib/utslvclauxiliary.tsf +++ b/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; diff --git a/funcext/tvclib/utvclgraphics.tsf b/funcext/tvclib/utvclgraphics.tsf index 19db048..c0db212 100644 --- a/funcext/tvclib/utvclgraphics.tsf +++ b/funcext/tvclib/utvclgraphics.tsf @@ -5,6 +5,7 @@ uses utslvclauxiliary; //20240126 //20240204 添加说明 //20240220 三维绘图功能 +//20240614 添加消息 { tg_const 常量类型，作为所有类型的基类，提供常量别名 tg_canvas 绘图画布对象，该对象以窗口中的canvas为父类，并增加了辅助函数 @@ -42,6 +43,9 @@ uses utslvclauxiliary; set_lineinfo_to_canvas(cvs,peninfo) 设置当前画笔信息到画布 set_fontinfo_to_canvas(cvs,info) 设置当前字体信息到画布 paint(cvs);virtual;该函数由tg_figure的管理者在适当时候发起，并送入tg_canvas对象 + addEventListener(etype,fun(e),ifCapture) //添加消息处理 + removeEventListener(etype,fun(e),ifCapture) //移除消息处理 + dispatchEvent(evt) ;//分发消息 tg_figure //坐标容器类，可以在上面放坐标系，设置坐标系的位置信息 add_axes(axes) 添加坐标系 @@ -51,6 +55,7 @@ uses utslvclauxiliary; 属性： rec_getter ：function() 返回画布区域 array(左上右下) fresh_caller: function() //刷新回调 + tg_axes 坐标系类型，作为绘图的基础载体，以及位置关系的基准 属性： title 标题 tg_label 类型 @@ -112,7 +117,32 @@ uses utslvclauxiliary; data array(x,y,z) 相对于坐标系的位置 tg_WinControl:绘图展示窗口对象，管理了一个 tg_figure 对象，在paint消息的时候构造tg_canvas 对象并调用tg_figrue的paint函数实现图形的绘制 - 其仅仅作为一个案例，用户可以按照其原理构造自己的画布对象，驱动绘制，得到图形 + 其仅仅作为一个案例，用户可以按照其原理构造自己的画布对象，驱动绘制，得到图形 + + 消息对象 + tg_evt 基类 + create(typename,pms) //构造函数 + bubbles //是否冒泡,只读 + currentTarget //当前绑定的对象,只读 + target //目标对象,只读 + stoppropagationed 否//已经调用 stoppropagation,只读 + stopImmediatePropagationed //是否已经调用 stopImmediatePropagation,只读 + eventPhase //只读,1,捕获,2到达目标,3,冒泡 + timeStamp //只读,加载完成到现在的时间 + eventtype //只读类型 + isTrusted //true表示用户触发,false表示代码触发 + init_params //初始化参数 数组 + tg_evt_mouse + cvsx ,cvsy //画布位置 + double 是否双击 + button 左右,中 按键 + ctrl ,shift //功能按键 + tg_evt_custom + detail + 目前提供 evt_mouse_up ,evt_mouse_down evt_mouse_move 三个消息 + 消息传播方式采用类似html对象的捕获和冒泡方式 + 捕获阶段,从figure对象向下一直传递到当目标对象 + 冒泡阶段,从目标对象向上传递到figure对象 } { //////////////////线图范例////////////////////////// @@ -367,8 +397,136 @@ type tfm = class(tvcform) end fg; end - +///////////////////////////消息处理/////////////////////////////////////////////////// +uses tslvcl,utvclgraphics; +app := initializeapplication(); +app.createform(class(tfm),fm); +fm.show(); +app.run(); +type tfm = class(tvcform) + function create(aowner); + begin + inherited; + fgwnd := new tg_WinControl(self); + fgwnd.Caption := "hello event"; + fgwnd.parent := self; + fgwnd.Align := alClient; + fg := fgwnd.figure; + axs := new tg_axes(); + axs.figure := fg; + axs.title.text := "你好 event "; + line := new tg_Polyline(); + line.parent := axs; + line.lineinfo.Width := 3; + line.lineinfo.bkcolor := 0xff00f0; + line.lineinfo.color := 0xff0000; + line.markinfo.bkcolor := 0x00ff00; + line.markinfo.color := 0x0000ff; + line.line_mode := 1; + line.markinfo.size := 20; + line.mark_mode := true; + line.markinfo.style := line.tgc_mks_pentagram; + line.polyline_style := line.tgc_LS_interpolated;//"bar"; + d2 := array(); + idx := 0; + for i:= -pi() to pi() step 0.3 do + begin + d2[idx++] := array(i,sin(i+pi()/2)); + end + line.graph_data := d2; + + gtx := new tg_text(); + gtx.font_angle := pi()/4; + //////////////命中处理/////////////// + gtx.onhit_at := function(o,d)begin + x := d["cvsx"]; + y := d["cvsy"]; + rgn := o.ExecuteCommand("text_rgn"); + return rgn and point_in_rgn(array(x,y),rgn); + end + gtx.lineinfo.bkcolor := 0x00ff00; + gtx.parent :=line; + gtx.text := array("按住鼠标左键","移动我"); + gtx.data := array(0.3,0.2); + //处理鼠标按下 + gtx.addEventListener("mouse_down",function(e)begin + fdragtext := e.target; + ftextinitpos := fdragtext.data; + x := e.cvsx;y := e.cvsy; + fdragtext.xyz_to_zoom(x,y,0,x1,y1); + fmousedownpos := array(x1,y1); + end); + //移动标签 + fg.addEventListener("mouse_move",function(e)begin + if fdragtext then + begin + e.stoppropagation(); + x := e.cvsx; + y := e.cvsy; + fdragtext.xyz_to_zoom(x,y,0,x1,y1); + dxdata := ftextinitpos+ array(x1-fmousedownpos[0],y1-fmousedownpos[1]); + fdragtext.data := dxdata; + end + end ,true); + //处理鼠标松开 + fg.addEventListener("mouse_up",function(e)begin + if fdragtext then + begin + e.stoppropagation(); + fdragtext := nil; + end + end ); + //构造提示标签 + fmovetip := new tg_tips(); + fmovetip.Visible := false; + fmovetip.clip_state := 0; + fmovetip.parent := line; + fmovetip.data_idx := 5; + fmovetip.fontinfo.size := 12; + fmovetip.box_mode := true;//false; + fmovetip.fontinfo.color := 0xff00ff; + //设置提示数据点 + line.onhit_at := function(o,d)begin + x := d["cvsx"]; + y := d["cvsy"]; + for i,v in o.ExecuteCommand("points_in_canvas") do + begin + if abs(v[0]-x)<10 and abs(v[1]-y)<10 then + begin + return true; + end + end + end + line.addEventListener("mouse_out",function(e)begin + if e.eventPhase<>2 then return ; + fmovetip.Visible := false; + e.stoppropagation(); + end,true); + line.addEventListener("mouse_move",function(e) + begin + if e.eventPhase<>2 then return ; + e.stoppropagation(); + x := e.cvsx; + y := e.cvsy; + for i,v in e.target.ExecuteCommand("points_in_canvas") do + begin + if abs(v[0]-x)<10 and abs(v[1]-y)<10 then + begin + fmovetip.Visible := true; + return fmovetip.data_idx := i; + end + end + end,true); + end + fdragtext; + ftextinitpos; + fmousedownpos; + fmovetip; + fgwnd; + fg; +end } +function point_in_rgn(p,rgn_); //判断点是否在区域中 type tg_WinControl = class(tcustomcontrol,tg_const) //绘图窗口 function create(AOwner); begin @@ -402,15 +560,47 @@ type tg_WinControl = class(tcustomcontrol,tg_const) // ffigureprepared := false; inherited; end + function MouseUp(o,e);override; + begin + if ffigure then + begin + d := e_2_array(e); + if ffigure.executecommand(evt_mouse_up,d)=1 then e.skip := true; + end + end + function MouseDown(o,e);override; + begin + if ffigure then + begin + d := e_2_array(e); + if ffigure.executecommand(evt_mouse_down,d)=1 then e.skip := true; + end + //echo "\r\n",functionname(),tostn(array(xy,bt,sh)); + end + function MouseMove(o,e);override; + begin + if ffigure then + begin + fmovecnt++; + if fmovecnt>4 then fmovecnt := 0; + if fmovecnt<>2 then return ; + d := e_2_array(e); + if ffigure.executecommand(evt_mouse_move,d)=1 then e.skip := true; + end + end function DoMouseWheel(o,e);override; begin p := ScreenToClient(e.xpos,e.ypos); - ffigure.executecommand("zoom_inc",array("delta":e.delta,"x":p[0],"y":p[1])); + if ffigure then + begin + ffigure.executecommand(cmd_zoom_inc,array("delta":e.delta,"x":p[0],"y":p[1])); + end end function DoWMSIZE(o,e);override; begin inherited; - ffigure.executecommand("figure_changed"); + if ffigure then + ffigure.executecommand(cmd_figure_changed); end function Recycling();override; begin @@ -422,17 +612,32 @@ type tg_WinControl = class(tcustomcontrol,tg_const) // function figure_need_fresh(o,e); //定时刷新 begin o.stop(); - //echo "\r\ninvalidate time:",datetimetostr(now()); InvalidateRect(nil,false); Fneed_invaliate := false; end - private + function e_2_array(e); + begin + d := array(); + st := e.shiftstate(); + sft := 0x0 in st; + sctl := 0x2 in st; + d := array( + "cvsx":e.xpos, + "cvsy":e.ypos, + "shift":sft, + "ctrl":sctl, + "button":e.button(), + ); + return d; + end + private + fmovecnt; ffigure; fg_timer; Fneed_invaliate; ffigureprepared; end -type tg_figure = class() ///////// +type tg_figure = class(tg_evet_conainter) ///////// function create(); begin inherited; @@ -445,7 +650,7 @@ type tg_figure = class() ///////// begin v.paint_pre(cvs); end - end + end function executecommand(cmd,p); begin case cmd of @@ -454,20 +659,32 @@ type tg_figure = class() ///////// fresh(); return ; end - "zoom_inc": + cmd_zoom_inc: begin for i,v in faxeses.data do begin - v.executecommand("zoom_inc",p); + v.executecommand(cmd_zoom_inc,p); end end - "figure_changed": + evt_mouse_move: + begin + return cmd_mouse_event(evt_mouse_move,p); + end + evt_mouse_up: + begin + return cmd_mouse_event(evt_mouse_up,p); + end + evt_mouse_down: + begin + return cmd_mouse_event(evt_mouse_down,p); + end + cmd_figure_changed: begin for i,v in faxeses.data do begin - v.executecommand("figure_changed"); + v.executecommand(cmd_figure_changed); end - end + end end ; end function add_axes(axs);//添加 @@ -507,10 +724,64 @@ type tg_figure = class() ///////// r := array(0,0,200,200); if frect_getter then r := call(frect_getter); return r; - end + end property rec_getter read frect_getter write frect_getter; //区域获取 property fresh_caller read ffresh_caller write ffresh_caller; //刷新回调 - private + public + function dispatchEvent(evt,nd); + begin + bs := evt.bubbles; + if ifarray(nd) then + begin + nds := nd; + end else + begin + nds := array(); + p := nd; + while p do + begin + nds[idx] := p; + idx++; + p := p.parent; + end + end + tg := nds[0]; + nds[length(nds)] := self(true); + for i := length(nds)-1 downto 0 do + begin + it := nds[i]; + ph := (i=0)?2:1; + d := array("eventphase":ph, + "target":tg, + "currenttarget":it, + ); + e := evt.clone(d); + it.dealevent(e,true); + if e.stoppropagationed then + begin + evt.stoppropagation(); + return true; + end + end + if not bs then return true; + for i := 0 to length(nds)-1 do + begin + it := nds[i]; + ph := (i=0)?2:3; + d := array("eventphase":ph, + "target":tg, + "currenttarget":it, + ); + e := evt.clone(d); + it.dealevent(e); + if e.stoppropagationed then + begin + evt.stoppropagation(); + return true; + end + end + end + private function get_axes_idx(axs); begin for i ,v in faxeses.data do @@ -522,12 +793,67 @@ type tg_figure = class() ///////// end return -1; end + function inverse_array(d); + begin + r := array(); + len := length(d)-1; + for i,v in d do + begin + r[len-i] := v; + end + return r; + end + function cmd_mouse_event(evtname,p); + begin + d := p; + for i,v in inverse_array(faxeses.data) do + begin + nds := node_hit_list(v,d); + if nds then + begin + break; + end + end + d["istrusted"] := true; + d["bubbles"] := true; + case evtname of + evt_mouse_move : + begin + ninnode := nds[0]; + if ninnode then + begin + if fMouseOnOBJ<> ninnode then //鼠标进入不同的控件 + begin + if fMouseOnOBJ then //旧控件 处理move out + begin + onds := array(); + nnd := fMouseOnOBJ; + while nnd do + begin + onds[length(onds)] := nnd; + nnd := nnd.parent; + end + evt := new tg_evt_mouse(evt_mouse_out,d); + dispatchEvent(evt,onds); + end + fMouseOnOBJ := ninnode; + evt := new tg_evt_mouse(evt_mouse_in,d); //处理mouse in + dispatchEvent(evt,nds); + end + end + end + end + evt := new tg_evt_mouse(evtname,d); + dispatchEvent(evt,nds); + return evt.stoppropagationed; + end private [weakref] frect_getter; [weakref] ffresh_caller; + [weakref] fMouseOnOBJ; fwilladdaxs; fwilldelaxs; - faxeses; + faxeses; end type tg_axes = class(tg_base) //坐标系 private @@ -548,7 +874,14 @@ type tg_axes = class(tg_base) // begin ochanged := f_changed; case cmd of - "zoom_inc": + "title_rgn": return ftitle.executecommand("label_rgn"); + "x_label_rgn": return (fx_label.visible=tgc_on)?faxes_objects[0].executecommand("label_rgn"):nil; + "y_label_rgn": return (fy_label.visible=tgc_on)?faxes_objects[1].executecommand("label_rgn"):nil; + "z_label_rgn": return (fz_label.visible=tgc_on)?faxes_objects[2].executecommand("label_rgn"):nil; + "x_tics_recs": return (fx_label.visible=tgc_on)?faxes_objects[0].executecommand("tics_recs"):nil; + "y_tics_recs": return (fy_label.visible=tgc_on)?faxes_objects[1].executecommand("tics_recs"):nil; + "z_tics_recs": return (fz_label.visible=tgc_on)?faxes_objects[2].executecommand("tics_recs"):nil; + cmd_zoom_inc: begin if not ifarray(pm) then return ; p0 := pm["x"]; @@ -564,7 +897,7 @@ type tg_axes = class(tg_base) // if not xyz_to_zoom(p0,p1,fzoom_box[2,0],x,y,z) then continue ; dx := ((pm["delta"]>0)?(1.05):(1/1.05)); if not zoom_bound_op(a0,b0,dx,array(x,y,z)[i],a,b) then continue ; - rt := 1; + rt := 1.1; cg := 0; if af_changed then prop_changed("data_changed",f_changed); + if ochanged<>f_changed then prop_changed(cmd_data_changed,f_changed); end function axes_mapping(x,y,z,_x,_y);override;//坐标系相对位置到画布 @@ -721,7 +1054,7 @@ type tg_axes = class(tg_base) // end end fdata_bounds := tbds; - fzoom_box := tbds; + fzoom_box := tbds*1.05; fzoom_bounds := fzoom_box; end /////////////计算旋转矩阵////////////////////////// @@ -1023,7 +1356,7 @@ type tg_axes = class(tg_base) // for ii in fbox_vertexs do //判断点是否在面的阴影中 begin if (ii in fc) then continue; - if point_in_rgn(fbox_vertexs[fc],fbox_vertexs[ii]) then + if point_in_rgn(fbox_vertexs[ii],fbox_vertexs[fc]) then begin inpoints[length(inpoints)] := ii; end @@ -1733,21 +2066,7 @@ type tg_axes = class(tg_base) // r := sselect thisrowindex from r order by thisrow desc end; return fface_v_indexs[r[0:2]]; end - function point_in_rgn(rgn_,p); //判断点是否在区域中 - begin - arg := 0; - rgn := rgn_ union array(rgn_[0]); - for i := 1 to length(rgn)-1 do - begin - p1 := rgn[i-1]; - p2 := rgn[i]; - v1 := array(p1[0]-p[0],p1[1]-p[1]); - v2 := array(p2[0]-p[0],p2[1]-p[1]); - argi := d2angle(v1,v2); - arg+=argi; - end - return (abs(arg/2-pi())<0.01); - end + end type tg_canvas = class(TcustomCanvas) uses utslvclgdi; @@ -1916,13 +2235,15 @@ type tg_axis = class(tg_base) // function executecommand(cmd,pm);override; begin case cmd of + "tics_recs" : return (visible=tgc_on)?ftics_recs:nil; + "label_rgn": return (flabel.visible=tgc_on)?flabel_rgn:nil; "get_tics_value":return fxtics_coord_v; "set_bounds": return set_zoom_bounds(pm); "get_angleofhoriz" : begin get_angleofhoriz(xarg,ifh,sz); return array(xarg,ifh,sz); - end + end end; end function paint(cvs);override; @@ -1971,6 +2292,8 @@ type tg_axis = class(tg_base) // property tics_labels read ftics_labels write set_tics_labels; // = ["2","3","4","5","6","7"] property axis_label read flabel write flabel; private + flabel_rgn; + ftics_recs; fzoom_bounds; fticksize; fsubticksize; @@ -2158,6 +2481,7 @@ type tg_axis = class(tg_base) // tcsinfo := array(); get_tic_to(ftics_direction,tksize,xarg,_xticlen,_yticklen); if ifnumber(ftics_color) then cvs.pen.color := ftics_color; + ftics_recs := array(); for i,vi in fxtics_coord_v do begin if fzoom_bounds and (vifzoom_bounds[1]) then continue; @@ -2205,6 +2529,7 @@ type tg_axis = class(tg_base) // end end tcsinfo[length(tcsinfo)] := array(lbi,rec,"h"); + ftics_recs[i] := rec; end end if tcsinfo then @@ -2223,6 +2548,7 @@ type tg_axis = class(tg_base) // cvs.lineto(array(_xstic+x,y+_ystic)); end //if not ax_pos then return ; + flabel_rgn := array(); if flabel is class(tg_label_axis) then //绘制标签 begin //tx := ax_pos[2]-ax_pos[1] @@ -2251,11 +2577,14 @@ type tg_axis = class(tg_base) // else _x+=sz*bs+ts_size[1]+tic_space; nx := x1+_x;//ax_pos[4]+_x; ny := y1+_y;//ax_pos[5]+_y; + t_rec := array(nx,ny,nx+slen,ny+lbft.size); + flabel_rgn := rec_to_points(t_rec); if like_0(nxarg) then begin cvs.textout(t,array(nx,ny)); end else begin + rgn_points_trans(flabel_rgn,-nxarg); cvs.SaveDC(); cvs.trans(-nxarg,nx,ny); cvs.textout(t,array(0,0)); @@ -2442,19 +2771,21 @@ type tg_text = class(tg_base) if clip_state=tgc_on then cvs.axesclip(); else cvs.axesunclip(); get_text_size(w,h,hi); - set_lineinfo_to_canvas(cvs); - + set_lineinfo_to_canvas(cvs); + FPaintrect := array(x,y,x+w,y+h); + Frgnpoints := rec_to_points(FPaintrect)[0:3]; if ffont_angle<>0 then begin cvs.SaveDC(); - cvs.trans(-ffont_angle,x,y); + cvs.trans(-ffont_angle,x,y); + rgn_points_trans(Frgnpoints,-ffont_angle); x := 0; y := 0; end if line_mode then begin rc := array(x,y,x+w,y+h); - cvs.draw_rect().rect(rc).draw(); + cvs.draw_rect().rect(rc).draw(); end set_fontinfo_to_canvas(cvs); for i,v in ftext do @@ -2464,11 +2795,21 @@ type tg_text = class(tg_base) if ffont_angle<>0 then cvs.RestoreDC(); end + function executecommand(cmd,p);override; + begin + case cmd of + "text_rec": return (visible=tgc_on)? FPaintrect:nil; + "text_rgn": return (visible=tgc_on)? Frgnpoints:nil; + end ; + return inherited; + end published property text read ftext write set_text; property data read fdata write set_data; property font_angle read ffont_angle write set_font_angle; private + FPaintrect; + Frgnpoints; ftext; fdata; ffont_angle; @@ -2555,9 +2896,13 @@ type tg_label =class(tg_base) // begin if not zoom_to_xyz(p[0],p[1],0,x_,y_) then return ; end - end + end + txtw := length(ftext)*fontinfo.size; + rec := array(x_,y_,x_+txtw,y_+fontinfo.size); + flabel_rgn := rec_to_points(rec)[0:3]; if ffont_angle<>0 then begin + rgn_points_trans(flabel_rgn,-ffont_angle); cvs.SaveDC(); cvs.trans(-ffont_angle,x_,y_); cvs.textout(ftext,array(0,0)); @@ -2573,6 +2918,10 @@ type tg_label =class(tg_base) // fauto_position_value := p; return ; end + "label_rgn": + begin + return (visible=tgc_on)?flabel_rgn:nil; + end end; return inherited; end @@ -2598,6 +2947,7 @@ type tg_label =class(tg_base) // //fractional_font ;//= "off" //font_angle ;//= 90 private + flabel_rgn; flocation; ftext; fposition; @@ -2694,11 +3044,14 @@ type tg_tips = class(tg_base) // FData := nil; ftext :=""; f_ps := nil; - end + prop_changed("fdata_idx",pm); + end + "tips_rec": return (visible=tgc_on)?FPaintrect:nil; end end function paint(cvs);override; begin + FPaintrect := array(); if tgc_on<>visible then return ; p := parent; if not p then return ; @@ -2735,6 +3088,7 @@ type tg_tips = class(tg_base) // lc := (fdata_idx+1) mod 3;//randomfrom(array(0,1,2,3)); end ; rec := get_rect_at_corner(x_,y_,sz[0],sz[1],msz,lc); + FPaintrect := rec; if fbox_mode=tgc_on then begin set_lineinfo_to_canvas(cvs); @@ -2742,10 +3096,12 @@ type tg_tips = class(tg_base) // end b_x := rec[0]; b_y := rec[1]; - set_fontinfo_to_canvas(cvs); + + set_fontinfo_to_canvas(cvs); + for i,v in ss do begin - rci := array(b_x,b_y,b_x+ws,b_y+hs[i]); + rci := array(b_x,b_y,b_x+ws,b_y+hs[i]); cvs.drawtext(v,rci); b_y+=hs[i]; end @@ -2768,6 +3124,7 @@ type tg_tips = class(tg_base) // fdata_idx; ftext; fdata; + FPaintrect; //auto_orientation ;//= "on" //orientation ;//= 3 //label_mode ;//= "on" @@ -2855,6 +3212,7 @@ type tg_tips = class(tg_base) // begin fdata_idx := idx ; executecommand("fresh",pm); + end end function set_location(v); @@ -2997,7 +3355,9 @@ type tg_legend = class(tg_base) //图 end; b_x := rc[0]; b_y := rc[1]; - set_fontinfo_to_canvas(cvs); + flegend_rec := rc; + set_fontinfo_to_canvas(cvs); + flegend_sub_recs := array(); for i,v in objs do begin hi := hs[i]; @@ -3006,6 +3366,7 @@ type tg_legend = class(tg_base) //图 rci := array(b_x,b_y,b_x+ws[0],b_y+hi); v.paint_legend(cvs,rci); end + flegend_sub_recs[i] := rci; si := ss[i]; if si then begin @@ -3016,6 +3377,14 @@ type tg_legend = class(tg_base) //图 end cvs.axesclip(); end + function executecommand(cmd,p);override; + begin + case cmd of + "legend_rec":return (visible=tgc_on)? flegend_rec:nil; + "legend_sub_recs":return (visible=tgc_on)? flegend_sub_recs:nil; + end + return inherited; + end published property location read flocation write set_location; property postion read fposition write set_postion; @@ -3031,6 +3400,8 @@ type tg_legend = class(tg_base) //图 flocation; FText; fposition; + flegend_rec; + flegend_sub_recs; //text ;//= "y1" //font_style ;//= 6 //font_size ;//= 1 @@ -3118,11 +3489,11 @@ type tg_legend = class(tg_base) //图 end function set_location(v); begin - vs := static array(tgc_in_upper_right,tgc_in_upper_left,tgc_in_lower_right,tgc_in_lower_left, + vs := static array(tgc_in_upper_right:true,tgc_in_upper_left:true,tgc_in_lower_right:true,tgc_in_lower_left:true, //tgc_out_upper_right,tgc_out_upper_left,tgc_out_lower_right,tgc_out_lower_left, - tgc_upper_caption,tgc_lower_caption, - tgc_by_coordinates,tgc_by_axes); - if v<>flocation and (v in vs) then + tgc_upper_caption:true,tgc_lower_caption:true, + tgc_by_coordinates:true,tgc_by_axes:true); + if v<>flocation and (vs[v]) then begin flocation := v; end @@ -3185,7 +3556,7 @@ type tg_graph = class(tg_graph_base) // end ax := axes; if ax then - ax.executecommand("data_changed"); + ax.executecommand(cmd_data_changed); end else begin inherited; @@ -3199,8 +3570,7 @@ type tg_graph = class(tg_graph_base) // fgraph_data := v; prop_changed("data",v); end - end - + end end type tg_Polyline = class(tg_graph) //线图对象 function create(pms); @@ -3252,15 +3622,23 @@ type tg_Polyline = class(tg_graph) // end end; end + fline_points_in_canvas := xys; //zoom_to_xyz(0,0,0,x,y); paint_lines(cvs,fpolyline_style,xys,fclosed,array("line_mode":line_mode,"bar_width":fbar_width,"color":lineinfo.color,"bkcolor":lineinfo.bkcolor,"xy0":ys)); - mk := markinfo; + mk := markinfo.clone(); if mark_mode=tgc_on and mk.size>2 then begin paint_marks(mk,cvs,xys); end inherited; end + function executecommand(cmd,p);override; + begin + case cmd of + "points_in_canvas":return (visible=tgc_on)? fline_points_in_canvas:nil; + end; + return inherited; + end function get_legend_size(w,h);virtual; begin mk := markinfo; @@ -3279,7 +3657,7 @@ type tg_Polyline = class(tg_graph) // xys := array((rec[0]+dis,y0),(rec[0]+4*dis,y0)); set_lineinfo_to_canvas(cvs); paint_lines(cvs,tgc_LS_interpolated,xys,0,array("line_mode":line_mode,"bar_width":fbar_width,"color":lineinfo.color,"bkcolor":lineinfo.bkcolor)); - mk := markinfo; + mk := markinfo.clone(); if mark_mode=tgc_on and mk.size>2 then begin xys := array((rec[0]+dis*2,y0),(rec[0]+3*dis,y0)); @@ -3290,6 +3668,7 @@ type tg_Polyline = class(tg_graph) // property polyline_style read fpolyline_style write set_polyline_style;//= "0" property bar_width read fbar_width write fbar_width;//= "0" private + fline_points_in_canvas; fdata_bounds; fclosed; fforeground; @@ -3354,6 +3733,16 @@ type tg_line_info = class(tg_const) FStyle := tgc_PS_SOLID; fbkcolor := nil; end + function clone(); + begin + r := new tg_line_info(); + r.style := fstyle; + r.width := FWidth; + r.size := FWidth; + r.color := fcolor; + r.bkcolor := fbkcolor; + return r; + end property Style read FStyle write FStyle; property width read FWidth write fwidth; property size read FWidth write fwidth; @@ -3373,6 +3762,15 @@ type tg_font_info = class(tg_const) // fforeground := 0; fbackground := nil; end + function clone(); + begin + r := new tg_font_info(); + r.style := fstyle; + r.size := fsize; + r.color := fforeground; + r.bkcolor := fbackground; + return r; + end property style read fstyle write fstyle; property size read fsize write fsize; property color read fforeground write fforeground; @@ -3393,6 +3791,16 @@ type tg_mark_info = class(tg_const) // fforeground := 0; fbackground := 0xffffff; end + function clone(); + begin + r := new tg_mark_info(); + r.Style := fstyle; + r.size := fsize; + r.size_unit := fsize_unit; + r.color := fforeground; + r.bkcolor := fbackground; + return r; + end property style read fstyle write fstyle; property size read fsize write fsize; property size_unit read fsize_unit write fsize_unit; @@ -3405,11 +3813,37 @@ type tg_mark_info = class(tg_const) // fforeground; fbackground; end -type tg_base = class(TNode,tg_const) //基类，提供层次关系结构 +type tg_evet_conainter = class(tg_const) + function create(); + begin + fCapturelist := new tevent_list(); + fbubblelist := new tevent_list(); + end + function addEventListener(evtype,fn,ifCapture);virtual; + begin + if ifCapture then return fCapturelist.add(evtype,fn); + return fbubblelist.add(evtype,fn); + end + function removeEventListener(evtype,fn,ifCapture); + begin + if ifCapture then return fCapturelist.remove(evtype,fn); + return fbubblelist.remove(evtype,fn); + end + function dealevent(evt,ifCapture); + begin + if ifCapture then return fCapturelist.dispatch(evt); + return fbubblelist.dispatch(evt); + end + private + fCapturelist; + fbubblelist; +end +type tg_base = class(TNode,tg_evet_conainter) //基类，提供层次关系结构 public function create(pms); begin - class(TNode).create(); + class(TNode).create(); + class(tg_evet_conainter).create(); fchange_locked := false; fclip_state := tgc_on; fvisibe := tgc_on; @@ -3439,7 +3873,7 @@ type tg_base = class(TNode,tg_const) // end function xyz_to_zoom(x,y,z,x_,y_,z_);virtual; begin - p := get_axes; + p := get_axes(); if p then return p.xyz_to_zoom(x,y,z,x_,y_,z_); return false; end @@ -3456,8 +3890,9 @@ type tg_base = class(TNode,tg_const) // vi.paint(cvs); end end - function hit_at(xy);virtual; + function hit_at(info):bool; begin + if fonhit_at then return call(fonhit_at,self(true),info) ; return false; end function set_lineinfo_to_canvas(cvs,info); @@ -3495,19 +3930,24 @@ 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 + if not(evt is class(tg_evt)) then return 1; + tg := self(true); + p := tg; + while p do + begin + if p is class(tg_axes) then + begin + p := p.figure; + break; + end + p := p.parent; + end + if not p then return 0; + return p.dispatchEvent(evt,tg); + end published property line_mode read fline_mode write set_line_mode; property mark_mode read fmark_mode write set_mark_mode; @@ -3518,7 +3958,7 @@ type tg_base = class(TNode,tg_const) // property markinfo read fmarkinfo; property fontinfo read ffontinfo; property change_locked read fchange_locked write fchange_locked; - + property onhit_at read fonhit_at write fonhit_at; public user_data; tag; @@ -3558,11 +3998,12 @@ type tg_base = class(TNode,tg_const) // if ct2>ct then begin ax := axes; - if ax then ax.executecommand("node_add_in",self(true)); + if ax then ax.executecommand(cmd_node_add_in,self(true)); end return r; end - private + private + [weakref]fonhit_at; fclip_state; fline_mode; fmark_mode; @@ -3673,11 +4114,26 @@ type tg_const = class() static const tgc_lower_caption = "lower_caption"; static const tgc_by_coordinates = "by_coordinates"; static const tgc_by_axes = "by_axes"; + //static const tgc_out_upper_right = "out_upper_right"; //static const tgc_out_upper_left = "out_upper_left"; //static const tgc_out_lower_right = "out_lower_right"; //static const tgc_out_lower_left = "out_lower_left"; ////////////// + static evt_mouse_down = "mouse_down"; + static evt_mouse_move = "mouse_move"; + static evt_mouse_in = "mouse_in"; + static evt_mouse_out = "mouse_out"; + static evt_mouse_up = "mouse_up"; + static const CAPTURING_PHASE = 1; + static const AT_TARGET = 2; + static const BUBBLING_PHASE = 3; + /////////////////////////// + static const cmd_zoom_inc = "zoom_inc"; + static const cmd_figure_changed = "figure_changed"; + static const cmd_data_changed = "data_changed"; + static const cmd_node_add_in = "node_add_in"; + end type tg_evt =class() //消息 function create(etype,pms); @@ -3698,27 +4154,31 @@ type tg_evt =class() // fbubbles := pms["bubbles"]?true:false; feventPhase := (pms["eventphase"]>0)?pms["eventphase"]:0; end - function preventdefault(); + function clone(d); //克隆对象 + begin + if ifarray(d) then d2 := fiparams union d; + else d2 := d; + co := self(true).Classinfo(1); + return createobject(co,feventtype,d2); + end + function preventdefault(); //阻止默认行为 begin fdefaultPrevented := true; end - function stoppropagation(); + function stoppropagation(); //停止传播 begin fstoppropagationed := true; end - function composedPath();//从触发元素到最外层Window - begin - return array(); - end - function stopImmediatePropagation(); + function stopImmediatePropagation(); //阻止当前类型的消息 begin FstopImmediatePropagationed := true; - end + end published property bubbles read fbubbles; //是否冒泡,只读 property currentTarget read fcurrentTarget;//当前绑定的对象,只读 property target read ftarget;//目标对象,只读 property stoppropagationed read fstoppropagationed;//是否已经调用 stoppropagation,只读 + property stopImmediatePropagationed read FstopImmediatePropagationed;//是否已经调用 stopImmediatePropagation,只读 property defaultPrevented read fdefaultPrevented;//是否已经调用 preventdefault,只读 property returnValue read freturnValue write freturnValue;//true表示正常执行,false表示阻止默认行为 property eventPhase read feventPhase;//只读,0,1,捕获,2到达目标,3,冒泡 @@ -3740,22 +4200,6 @@ type tg_evt =class() // 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 @@ -3767,10 +4211,111 @@ type tg_evt_custom = class(tg_evt) // private fdetail; end +type tg_evt_mouse = class(tg_evt_custom) //鼠标消息 + function create(etyp,pms); + begin + inherited; + if ifarray(pms) then + begin + fcvsx := pms["cvsx"]; + fcvsy := pms["cvsy"]; + fdouble := pms["double"]; + fshift := pms["shift"]; + fctl := pms["ctrl"]; + end + end + property cvsx read fcvsx; + property cvsy read fcvsy; + property shift read fshift; + property double read fdouble; + property ctrl read fctrl; + private + fcvsx; + fcvsy; + fshift; + fdouble; + fctrl; +end + implementation +///////////事件存储对象/////////////////////// +type tevent_item = class() + function create(n,f); + begin + ename := n; + efunc := f; + end + ename; + [weakref]efunc; +end +type tevent_list = class() + function create(); + begin + FItems := array(); + end + function add(n,f); + begin + if not(ifstring(n) and n) then return 0; + if not ifobj(f) then return 0; + for i,v in FItems do + begin + if (v.ename=n and v.efunc=f) then return ; + end + FItems[length(FItems)] := new tevent_item(n,f); + return true; + end + function remove(n,f); + begin + idx := -1; + for i,v in FItems do + begin + if (ifnil(f) and v.ename = n) or (ifnil(n) and v.efunc=f) or (v.efunc=f and v.ename = n) then + begin + idx := i; + break; + end + end + if idx>0 then + begin + deleteindex(FItems,idx); + remove(n,f); + end + end + function dispatch(e); + begin + for i,it in FItems do + begin + if it then + begin + if e.stoppropagationed or e.stopImmediatePropagationed then return ; + f := it.efunc; + n := it.ename; + if f and n=e.eventtype then call(f,e); + end + end + end + FItems; +end +function node_hit_list(nd,info); //节点命中 +begin + nnd := node_hit_at(nd,info); + r := array(); + if nnd then + begin + r[0] := nnd ; + idx := 1; + while nnd do + begin + nnd := nnd.parent; + if nnd then r[idx] := nnd; + idx++; + end + end + return r; +end function node_hit_at(nd,info); //命中处理 begin - if not(nd.visible) then return 0; + if (nd.visible=nd.tgc_off) then return 0; nct := nd.NodeCount; if nct>0 then begin @@ -4214,6 +4759,29 @@ 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 point_in_rgn(p,rgn_); //判断点是否在区域中 +begin + arg := 0; + rgn := rgn_ union array(rgn_[0]); + for i := 1 to length(rgn)-1 do + begin + p1 := rgn[i-1]; + p2 := rgn[i]; + v1 := array(p1[0]-p[0],p1[1]-p[1]); + v2 := array(p2[0]-p[0],p2[1]-p[1]); + argi := d2angle(v1,v2); + arg+=argi; + end + return (abs(arg/2-pi())<0.01); +end +function rgn_points_trans(pts,ag); +begin + for i := 1 to length(pts)-1 do + begin + p_trans(pts[i,0]-pts[0,0],pts[i,1]-pts[0,1],ag,px,py); + pts[i] := array(pts[0,0]+px,pts[0,1]+py); + end +end function tg_get_true_idx(idx); begin nidx := idx; diff --git a/plugin/TSLCPLUGIN.DLL b/plugin/TSLCPLUGIN.DLL index 9478ba6..32cfeee 100644 Binary files a/plugin/TSLCPLUGIN.DLL and b/plugin/TSLCPLUGIN.DLL differ diff --git a/plugin/TSLUIL.dll b/plugin/TSLUIL.dll deleted file mode 100644 index 4063ae1..0000000 Binary files a/plugin/TSLUIL.dll and /dev/null differ diff --git a/tsleditor.exe b/tsleditor.exe index 96d531b..7355d25 100644 Binary files a/tsleditor.exe and b/tsleditor.exe differ diff --git a/tslkrnl.dll b/tslkrnl.dll index 060213e..d902e88 100644 Binary files a/tslkrnl.dll and b/tslkrnl.dll differ diff --git a/whatsnew.txt b/whatsnew.txt index 28cff9b..ce3bc0e 100644 --- a/whatsnew.txt +++ b/whatsnew.txt @@ -1,3 +1,6 @@ +更新日志--------2024-06-11 + 修正：启用的新的流格式存在诱发崩溃的问题。 + 更新日志--------2024-06-02 修正：officeplugin的问题。 修正：数据库连接采用JDBC驱动时在无主键sqltable插入时数据异常时的问题。