liujianjun/tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity

tsl64

Browse Source 
更新动态库
This commit is contained in:
liujianjun
2024-06-18 14:11:47 +08:00
parent 1ed266f959
commit d46e01f8fb
14 changed files with 915 additions and 162 deletions
Download Patch File Download Diff File Expand all files Collapse all files
MathKrnl.dll
BIN
View File
Binary file not shown.
PK_SQL.DLL
BIN
View File
Binary file not shown.
PK_SQL_MYSQL.DLL
BIN
View File
Binary file not shown.
PK_SQL_ODBC.DLL
BIN
View File
Binary file not shown.
PK_SQL_POSTGRESQL.DLL
BIN
View File
Binary file not shown.
TSLInterp.dll
BIN
View File
Binary file not shown.
funcext/tvclib/utslvcl_com.tsf
+234 -60
View File
@@ -34,7 +34,7 @@ interface
end end
end end
*) *)
uses cstructurelib,tslvcl; uses cstructurelib,utslvclauxiliary,tslvcl;
function sh_get_IShellLinkW(); //获取快捷方式创建接口 function sh_get_IShellLinkW(); //获取快捷方式创建接口
function create_short_cutA(targ,lnk);//创建文件快捷方式 function create_short_cutA(targ,lnk);//创建文件快捷方式
type tagELEMDESC_test =class(tagELEMDESC) type tagELEMDESC_test =class(tagELEMDESC)
@@ -156,6 +156,10 @@ type t_com_class = class()
function execute_retun_is_excel(fname);virtual;//返回时候参数是否为excel格式 function execute_retun_is_excel(fname);virtual;//返回时候参数是否为excel格式
begin begin
return false; return false;
end
function method_names();virtual; //函数名称
begin
end end
function invoke_call(fname,pms);virtual; //执行函数 function invoke_call(fname,pms);virtual; //执行函数
begin begin
@@ -349,12 +353,10 @@ type t_com_class = class()
end end
function getguid(); function getguid();
begin begin
global G_CURRENT_CLSID;
if not sguid then if not sguid then
begin begin
sguid := new tguid(); sguid := new tguid();
G_CURRENT_CLSID := get_clsid(); sguid.readstr(get_clsid());
sguid.readstr(G_CURRENT_CLSID);
end end
return sguid; return sguid;
end end
@@ -451,6 +453,16 @@ type tagFUNCKIND = class
static const FUNC_DISPATCH = ( FUNC_STATIC + 1 ) ; static const FUNC_DISPATCH = ( FUNC_STATIC + 1 ) ;
end 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 type tagINVOKEKIND =class
static const INVOKE_FUNC = 1; static const INVOKE_FUNC = 1;
static const INVOKE_PROPERTYGET = 2; static const INVOKE_PROPERTYGET = 2;
@@ -529,14 +541,83 @@ type tagwinerr =class
static const E_ABORT=0x80004004L; static const E_ABORT=0x80004004L;
static const E_FAIL=0x80004005L; static const E_FAIL=0x80004005L;
static const E_ACCESSDENIED=0x80070005L; static const E_ACCESSDENIED=0x80070005L;
static const DISP_E_EXCEPTION=0x80020009L;
static const S_OK = 0; static const S_OK = 0;
end 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, type tcom_const = class(tagTYPEKIND,tagDESCKIND,tagTYPEFLAGS,
tagFUNCFLAGS,tagVARFLAGS, tagFUNCFLAGS,tagVARFLAGS,
tagFUNCKIND,tagCALLCONV,tagINVOKEKIND,tagVARKIND, tagFUNCKIND,tagCALLCONV,tagINVOKEKIND,DISPID_TYPE,tagVARKIND,
tagvtype,tagwinerr) tagvtype,tagwinerr,FACILITY_DISPATCH)
////// //////
/////////////////////////// ///////////////////////////
static const IMPLTYPEFLAG_FDEFAULT = 1; static const IMPLTYPEFLAG_FDEFAULT = 1;
@@ -544,7 +625,6 @@ type tcom_const = class(tagTYPEKIND,tagDESCKIND,tagTYPEFLAGS,
static const IMPLTYPEFLAG_FRESTRICTED = 4; static const IMPLTYPEFLAG_FRESTRICTED = 4;
static const IMPLTYPEFLAG_FDEFAULTVTABLE = 8; static const IMPLTYPEFLAG_FDEFAULTVTABLE = 8;
//////////////////////////////// ////////////////////////////////
//////////////// ////////////////
static const DISPATCH_METHOD = 0x1; static const DISPATCH_METHOD = 0x1;
static const DISPATCH_PROPERTYGET = 0x2; static const DISPATCH_PROPERTYGET = 0x2;
@@ -922,9 +1002,9 @@ type tagTYPEATTR = class(tcom_stc_base)
("lpstrSchema","intptr",0), ("lpstrSchema","intptr",0),
("cbSizeInstance","int",0), //此类型的实例的大小。 ("cbSizeInstance","int",0), //此类型的实例的大小。
("typekind","int",4), //TYPEKIND 值描述此信息所描述的类型。//TKIND_DISPATCH ("typekind","int",4), //TYPEKIND 值描述此信息所描述的类型。//TKIND_DISPATCH
("cFuncs","short",10), //指示此结构描述的接口上的函数数目。 ("cFuncs","short",1), //指示此结构描述的接口上的函数数目。
("cVars","short",10), //指示此结构所描述的接口上的变量和数据字段的数目。 ("cVars","short",0), //指示此结构所描述的接口上的变量和数据字段的数目。
("cImplTypes","short",100), //指示此结构描述的接口上实现的接口的数量。 ("cImplTypes","short",0), //指示此结构描述的接口上实现的接口的数量。
("cbSizeVft","short",0), // 此类型的虚拟方法表 (VTBL) 的大小。 ("cbSizeVft","short",0), // 此类型的虚拟方法表 (VTBL) 的大小。
("cbAlignment","short",8), //指定此类型实例的字节对齐方式。 ("cbAlignment","short",8), //指定此类型实例的字节对齐方式。
("wTypeFlags","short",TYPEFLAG_FDISPATCHABLE), //tagTYPEFLAGS ("wTypeFlags","short",TYPEFLAG_FDISPATCHABLE), //tagTYPEFLAGS
@@ -933,9 +1013,9 @@ type tagTYPEATTR = class(tcom_stc_base)
("tdescAlias","user",class(tagTYPEDESC).TYPEDESC_stc), ("tdescAlias","user",class(tagTYPEDESC).TYPEDESC_stc),
("idldescType","user",class(tagIDLDESC).IDLDESC_stc) ("idldescType","user",class(tagIDLDESC).IDLDESC_stc)
); );
end end
public public
property cFuncs index "cFuncs" read _getvalue_ write _setvalue_;
function guidobj(); function guidobj();
begin begin
ptr := _getvalueaddr2_("guid"); ptr := _getvalueaddr2_("guid");
@@ -993,6 +1073,17 @@ type tagDISPPARAMS = class(tcom_stc_base)
stc := static MemoryAlignmentCalculate(DISPPARAMS_Stc()); stc := static MemoryAlignmentCalculate(DISPPARAMS_Stc());
inherited create(stc,ptr); inherited create(stc,ptr);
end 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); function getarg(idx);
begin begin
if (idx >=0) and (idx<_getvalue_("cArgs")) then if (idx >=0) and (idx<_getvalue_("cArgs")) then
@@ -1045,9 +1136,13 @@ type tptrarray =class(tslcstructureobj)
); );
inherited create(stc,ptr); inherited create(stc,ptr);
end end
function ansistr(); function ansistr(idx);
begin begin
p := _getvalue_("ptr"); if idx>0 then
begin
p := mtool().readptr( int64(_getptr_()+idx*8));
end else
p := _getvalue_("ptr");
return wideptrtoansi(p); return wideptrtoansi(p);
end end
end end
@@ -1145,7 +1240,8 @@ type iunkown =class(tcom_const)
end end
end end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual; function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
begin begin
ppv := 0;
if IID_IUnknown.equ(riid) then if IID_IUnknown.equ(riid) then
begin begin
ppv := _getptr_(); ppv := _getptr_();
@@ -1211,6 +1307,11 @@ type func_mid_cache = class
frgDispIds; frgDispIds;
frgDispIds2; frgDispIds2;
end 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) type idispatch=class(iunkown)
protected protected
static IID_IDispatch; static IID_IDispatch;
@@ -1223,6 +1324,7 @@ type idispatch=class(iunkown)
[weakref] fcom_mgr; [weakref] fcom_mgr;
function create(ptr) function create(ptr)
begin begin
inherited ;//create(getstruct(),ptr); inherited ;//create(getstruct(),ptr);
if not IID_IDispatch then if not IID_IDispatch then
begin begin
@@ -1230,40 +1332,60 @@ type idispatch=class(iunkown)
IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}"); IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");
end end
if not ptr then if not ptr then
begin begin
fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount))); fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));
fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo))); fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));
fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames))); fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));
fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_))); fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));
//echo tostn(fvtable._getdata_);
end end
fglobalL := TS_GetGlobalL(); fglobalL := TS_GetGlobalL();
end end
function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual; function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
begin begin
//echo "\r\n>>>>>>idispatch:",functionname(1); return E_NOTIMPL;
echo "\r\n>>>>>>idispatch:",functionname(1);
pctinfo := 0; 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 1;
//return E_NOTIMPL S_OK
end end
function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual; function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual;
begin begin
//echo "\r\n>>>>>>idispatch:",functionname(1),iTInfo," ",lcid," ",ppTInfo; //echo "\r\n>>>>>>idispatch:",functionname(1),iTInfo," ",lcid," ",ppTInfo;
ppTInfo := 0;
return E_NOTIMPL; return E_NOTIMPL;
if not fcom_mgr.method_names() then return E_NOTIMPL;
if not ftypeinfo then if not ftypeinfo then
begin begin
ftypeinfo := new ITypeInfo(); ftypeinfo := new ITypeInfo();
ftypeinfo.fcom_mgr := fcom_mgr;
end end
ppTInfo := ftypeinfo._getptr_(); ppTInfo := ftypeinfo._getptr_();
echo "====",ppTInfo;
return S_OK; return S_OK;
return E_NOTIMPL; //return S_OK, DISP_E_BADINDEX
end end
function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;virtual; function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;virtual;
begin 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; if cnames>1 then return E_INVALIDARG;
ostr := new tptrarray(rgszNames); ostr := new tptrarray(rgszNames);
rgDispId := get_func_str_id(ostr.ansistr); rgDispId := get_func_str_id(ostr.ansistr());
return S_OK; return S_OK;
//E_OUTOFMEMORY DISP_E_UNKNOWNNAME DISP_E_UNKNOWNLCID
end end
function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer; function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer;
pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual; pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
@@ -1275,7 +1397,6 @@ type idispatch=class(iunkown)
FInvokename := fname; FInvokename := fname;
if pVarResult then if pVarResult then
begin begin
//AddRef(s);
rv := new tagVARIANT( pVarResult); rv := new tagVARIANT( pVarResult);
rv._setvalue_("vt" , VT_DISPATCH); rv._setvalue_("vt" , VT_DISPATCH);
rv._setvalue_("data",s); rv._setvalue_("data",s);
@@ -1289,16 +1410,18 @@ type idispatch=class(iunkown)
pms := trans_params(pDispParams); pms := trans_params(pDispParams);
x := fcom_mgr.invoke_call(fname,pms); x := fcom_mgr.invoke_call(fname,pms);
if pVarResult then ObjToVariantRef(fglobalL,x,pVarResult,fcom_mgr.execute_retun_is_excel(fname)); if pVarResult then ObjToVariantRef(fglobalL,x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
return 0; return S_OK;
end else end else
if wFlags = 4 then if (wFlags .& 4) or (wFlags .& 8) then
begin begin
fcom_mgr.invoke_propertyset(fname,trans_params(pDispParams)[0]); fcom_mgr.invoke_propertyset(fname,trans_params(pDispParams)[0]);
end end
return 0; return S_OK;
//////////////返回很多错误类型//////
end end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual; function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
begin begin
ppv := 0;
if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then
begin begin
ppv := _getptr_(); ppv := _getptr_();
@@ -1316,10 +1439,16 @@ type idispatch=class(iunkown)
end end
return r; return r;
end end
function AddRef(s:pointer):integer;stdcall;virtual;
begin
r := inherited;
return r;
end
private private
function trans_params(pDispParams); function trans_params(pDispParams);
begin begin
o := new tagDISPPARAMS(pDispParams); o := new tagDISPPARAMS(pDispParams);
//echo "\r\ncnamecout:",tostn(o.getcnameargs());
pp := o.getArgs(); pp := o.getArgs();
pms := array(); pms := array();
for idx,p1 in pp do for idx,p1 in pp do
@@ -1341,6 +1470,7 @@ type ITypeInfo=class(iunkown)
return new ITypeInfoVtbl(ptr); return new ITypeInfoVtbl(ptr);
end end
public public
[weakref] fcom_mgr;
function create(ptr) function create(ptr)
begin begin
nptr := not ptr; nptr := not ptr;
@@ -1377,6 +1507,7 @@ type ITypeInfo=class(iunkown)
end end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual; function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
begin begin
ppv := 0;
if IID_IUnknown.equ(riid) or IID_ITypeInfo.equ(riid) then if IID_IUnknown.equ(riid) or IID_ITypeInfo.equ(riid) then
begin begin
ppv := _getptr_(); ppv := _getptr_();
@@ -1404,12 +1535,13 @@ type ITypeInfo=class(iunkown)
if ifnil(ftypeattr) then if ifnil(ftypeattr) then
begin begin
ftypeattr := new tagTYPEATTR(); ftypeattr := new tagTYPEATTR();
global G_CURRENT_CLSID; ftypeattr.guidobj().readstr(fcom_mgr.get_clsid());
ftypeattr.guidobj().readstr(G_CURRENT_CLSID); ns := fcom_mgr.method_names();
if ifarray(ns) then ftypeattr.cFuncs := length(ns) ;
end end
pptypeattr := ftypeattr._getptr_(); pptypeattr := ftypeattr._getptr_();
return S_OK; return S_OK;
//return E_NOTIMPL; //return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
end end
function GetTypeComp(sf:pointer;var ppTComp:pointer):integer;stdcall;virtual; function GetTypeComp(sf:pointer;var ppTComp:pointer):integer;stdcall;virtual;
begin begin
@@ -1420,33 +1552,36 @@ type ITypeInfo=class(iunkown)
fITypecomp.fitypeinfo := sf; fITypecomp.fitypeinfo := sf;
end end
ppTComp := fITypecomp._getptr_(); ppTComp := fITypecomp._getptr_();
return 0; return S_OK;
//return E_NOTIMPL; //return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
end end
function GetFuncDesc(sf:pointer;idx:integer;var ppFuncDesc:pointer):integer;stdcall;virtual; function GetFuncDesc(sf:pointer;idx:integer;var ppFuncDesc:pointer):integer;stdcall;virtual;
begin begin
echo "\r\n===ITypeInfo:",functionname(1)," ",idx," ",ppFuncDesc; echo "\r\n===ITypeInfo:",functionname(1)," ",idx," ",ppFuncDesc;
//return E_NOTIMPL; //return E_NOTIMPL;
if not fFuncDesc then fFuncDesc := get_funcs_info(); if not fFuncDesc then fFuncDesc := get_funcs_info();
fFuncDesc._setvalue_("memid",idx); fFuncDesc._setvalue_("memid",idx+1);
ppFuncDesc := fFuncDesc._getptr_(); ppFuncDesc := fFuncDesc._getptr_();
return S_OK; return S_OK;
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
end end
fFuncDesc; 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 begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
//return E_NOTIMPL; return E_NOTIMPL;
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1)," ",memid," ",rgBstrNames," ",cMaxNames," ",pcNames; echo "\r\n===ITypeInfo:",functionname(1)," ",memid," ",rgBstrNames," ",cMaxNames," ",pcNames;
return E_NOTIMPL; return E_NOTIMPL;
//return E_INVALIDARG ,E_OUTOFMEMORY,S_OK;
end end
function GetRefTypeOfImplType(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual; function GetRefTypeOfImplType(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual;
begin begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
//return E_NOTIMPL; return E_NOTIMPL;
end end
function GetImplTypeFlags(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual; function GetImplTypeFlags(sf:pointer;index:integer;pRefType:pointer):integer;stdcall;virtual;
begin begin
@@ -1462,53 +1597,67 @@ type ITypeInfo=class(iunkown)
pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual; pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
begin begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
return E_NOTIMPL; return E_NOTIMPL;
//return DISP_E_EXCEPTION E_INVALIDARG S_OK;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1); 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; return E_NOTIMPL;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
return E_NOTIMPL; pbstrdllname := 0;
pbstrname := 0;
pwordinal := 0;
return S_OK;
//return E_INVALIDARG,E_OUTOFMEMORY;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
return E_NOTIMPL; return E_NOTIMPL;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
return E_NOTIMPL; return E_NOTIMPL;
//return S_OK;
end end
function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;// function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;//
begin begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
return E_NOINTERFACE;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
return E_NOTIMPL; pBstrMops := 0;
return S_OK;
end 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 begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
ppTLib := 0;ppTLib := -1;
return E_NOINTERFACE;
return E_NOTIMPL; return E_NOTIMPL;
end end
procedure ReleaseTypeAttr(sf:pointer;pTypeAttr:pointer);stdcall;virtual; procedure ReleaseTypeAttr(sf:pointer;pTypeAttr:pointer);stdcall;virtual;
begin begin
echo "\r\n===ITypeInfo:",functionname(1)," ",sf; echo "\r\n===ITypeInfo:",functionname(1)," ",sf;
pTypeAttr := 0; //pTypeAttr := 0;
//ftypeattr := nil;
end end
procedure ReleaseFuncDesc(sf:pointer;pFuncDesc:pointer);stdcall;virtual; procedure ReleaseFuncDesc(sf:pointer;pFuncDesc:pointer);stdcall;virtual;
begin begin
echo "\r\n===ITypeInfo:",functionname(1); echo "\r\n===ITypeInfo:",functionname(1);
//pFuncDesc := 0; //pFuncDesc := 0;
//fFuncDesc := nil;
end end
procedure ReleaseVarDesc(sf:pointer;pVarDesc:pointer);stdcall;virtual; procedure ReleaseVarDesc(sf:pointer;pVarDesc:pointer);stdcall;virtual;
begin begin
@@ -1516,8 +1665,7 @@ type ITypeInfo=class(iunkown)
end end
private private
ftypeattr; ftypeattr;
fITypecomp; fITypecomp;
end end
function get_funcs_info(); function get_funcs_info();
begin begin
@@ -1534,6 +1682,7 @@ type ITypecomp=class(iunkown)
return new ITypecompVtbl(ptr); return new ITypecompVtbl(ptr);
end end
public public
[weakref] fcom_mgr;
function create(ptr) function create(ptr)
begin begin
nptr := not ptr; nptr := not ptr;
@@ -1552,6 +1701,7 @@ type ITypecomp=class(iunkown)
end end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override; function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
begin begin
ppv := 0;
if IID_IUnknown.equ(riid) or IID_ITypeComp.equ(riid) then if IID_IUnknown.equ(riid) or IID_ITypeComp.equ(riid) then
begin begin
ppv := _getptr_(); ppv := _getptr_();
@@ -1651,6 +1801,7 @@ type IClassFactory=class(iunkown)
end end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override; function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
begin begin
ppv := 0;
if IID_IUnknown.equ(riid) or IID_IClassFactory.equ(riid) then if IID_IUnknown.equ(riid) or IID_IClassFactory.equ(riid) then
begin begin
ppv := _getptr_(); ppv := _getptr_();
@@ -1912,6 +2063,9 @@ end
function wideptrtoansi(p); function wideptrtoansi(p);
begin begin
if not p then return "";
r := wideptr_to_ansi(p);
return r;
wlen := uaw_wcslen(p); wlen := uaw_wcslen(p);
sansi := ""; sansi := "";
if wlen>0 then if wlen>0 then
@@ -1925,9 +2079,26 @@ begin
end end
return sansi; return sansi;
end 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 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 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 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"; 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 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; function MultiByteToWideChar(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;
cchMultiByte:integer;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"; 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 initialization
end. end.
funcext/tvclib/utslvclauxiliary.tsf
+10 -2
View File
@@ -1653,7 +1653,7 @@ type TNode = class() //
bidx := idx0; bidx := idx0;
for i,it in its do for i,it in its do
begin begin
if(it is class(TNode))and(not it.Parent)then if node_insert_check(it) then
begin begin
FItems.InsertBefor(it,idx0); FItems.InsertBefor(it,idx0);
FCurrentAddNode := it; FCurrentAddNode := it;
@@ -1670,7 +1670,7 @@ type TNode = class() //
@param(it)(TNode) 字符串 %% @param(it)(TNode) 字符串 %%
@param(idx)(integer) 序号 默认为0 %% @param(idx)(integer) 序号 默认为0 %%
**} **}
if(it is class(TNode))and(not it.Parent)then if node_insert_check(it) then
begin begin
if idx<0 then idx := 0; if idx<0 then idx := 0;
if idx>FItems.Count then idx := FItems.Count; if idx>FItems.Count then idx := FItems.Count;
@@ -1682,6 +1682,10 @@ type TNode = class() //
return true; return true;
end end
end end
function node_insert_check(it);virtual;
begin
return (it is class(TNode))and(not it.Parent);
end
function Expand();virtual; //展开 function Expand();virtual; //展开
begin begin
FExpanded := true; FExpanded := true;
@@ -4317,6 +4321,10 @@ end
function get_tsl_mem_ptr(s,n); function get_tsl_mem_ptr(s,n);
begin begin
ptr := static makeinstance(thisfunction(get_tsl_ptr_drift)); 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 if ifstring(s) then
begin begin
_f_ := static function(var v:string;n:integer):pointer;cdecl;external ptr; _f_ := static function(var v:string;n:integer):pointer;cdecl;external ptr;
funcext/tvclib/utvclgraphics.tsf
+668 -100
View File
File diff suppressed because it is too large Load Diff
plugin/TSLCPLUGIN.DLL
BIN
View File
Binary file not shown.
plugin/TSLUIL.dll
BIN
View File
Binary file not shown.
tsleditor.exe
BIN
View File
Binary file not shown.
tslkrnl.dll
BIN
View File
Binary file not shown.
whatsnew.txt
+3
View File
@@ -1,3 +1,6 @@
更新日志--------2024-06-11
修正：启用的新的流格式存在诱发崩溃的问题。
更新日志--------2024-06-02 更新日志--------2024-06-02
修正：officeplugin的问题。 修正：officeplugin的问题。
修正：数据库连接采用JDBC驱动时在无主键sqltable插入时数据异常时的问题。 修正：数据库连接采用JDBC驱动时在无主键sqltable插入时数据异常时的问题。