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

编辑器 

修正赋值运算符问题
This commit is contained in:
tslediter 2023-11-27 14:34:40 +08:00
parent 958c17a134
commit 362e8a697b
6 changed files with 367 additions and 349 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
designer/utslcodeeditor.tsf
View File

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

2
designer/utslcodeformat.tsf
View File

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

BIN
editor-install.exe
View File

Binary file not shown.

8
funcext/tvclib/tgdiplusflat.tsf
View File

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

651
funcext/tvclib/utslvcl_com.tsf
View File

@ -18,6 +18,7 @@ interface
com := new my_com();
return com.do_command();
type my_com=class(t_com_class)
uses utslvcl_com;
function create();
begin
inherited;
@ -32,19 +33,56 @@ interface
end
end
*)
uses tslvcl;
uses cstructurelib,tslvcl;
function sh_get_IShellLinkW(); //获取快捷方式创建接口
function create_short_cutA(targ,lnk);//´´½¨Îļþ¿ì½Ý·½Ê½
type tiunkown = class(iunkown) //对外输出com接口
function create(ptr)
type inukownvtb = class(tslcstructureobj)
function create(ptr);
begin
inherited;
struct := MemoryAlignmentCalculate(get_vtb_struct());
inherited create(struct,ptr);
end
protected
function get_vtb_struct();virtual;
begin
return array(
("QueryInterface","intptr",0),
("AddRef","intptr",0),
("Release","intptr",0)
);
end
end
type tIClassFactory = class(IClassFactory)
type idispatchvtb =class(inukownvtb)
public
function create(ptr)
begin
inherited;
inherited ;
end
protected
function get_vtb_struct();override;
begin
return inherited union array(
("GetTypeInfoCount","intptr",0),
("GetTypeInfo","intptr",0),
("GetIDsOfNames","intptr",0),
("Invoke","intptr",0)
);
end
end
type iClassFactoryvtb =class(inukownvtb)
public
function create(ptr)
begin
inherited ;
end
protected
function get_vtb_struct();override;
begin
return inherited union array(
("CreateInstance","intptr",0),
("LockServer","intptr",0)
);
end
end
type tclsguid = class(tguid) //clsid¶ÔÏó
function create(ptr);
@ -116,8 +154,9 @@ type t_com_class = class()
if si="-uninstall" then
begin
return do_uninstall();
end
end
end
//sleep(10000);
end
function install_success();virtual;
begin
@ -131,14 +170,16 @@ type t_com_class = class()
function do_install();
begin
do_install_sub();
echo "\r\n输入回车键退出";
s := readln();
echo "\r\n10秒后退出";
sleep(10000);
//s := readln();
end
function do_uninstall();
begin
do_uninstall_sub();
echo "\r\n输入回车键退出";
s := readln();
echo "\r\n10秒后退出";
sleep(10000);
//s := readln();
end
function do_install_sub();
begin
@ -336,19 +377,6 @@ type tcom_const = class
end
type tguid=class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("data1","int",0xf59a8177),
("data2","short",0x2a0),
("data3","short",0x4019),
("data4","byte[8]",array(0xa3, 0x93, 0xaf, 0x7, 0x9f, 0x9a, 0xb3, 0x62)),
)
);
return SSTRUCT;
end
public
function create(ptr)
begin
@ -361,7 +389,56 @@ type tguid=class(tslcstructureobj)
_setvalue_("data2",r[1]);
_setvalue_("data3",r[2]);
_setvalue_("data4",r[3:]);
end
function asstr(); //转换为
begin
r := _getdata_();
s := "{";
s += format("%8X",R["data1"]);
s+="-";
s += format("%4X",R["data2"]);
s+="-";
s += format("%4X",R["data3"]);
s+="-";
for i:= 0 to 1 do
begin
s+=format("%2x",r["data4",i]);
end
s+="-";
for i:= 2 to 7 do
begin
s+=format("%2x",r["data4",i]);
end
s+="}";
return replacetext(s," ","0");
end
function equ(riid); //相等
begin
if ifstring(riid) then return asstr()=riid;
if ifarray(riid) then
begin
return _getdata_()=riid ;
end
if riid>0 or riid<0 then
begin
d := _getdata_();
o := new tguid(riid);
return d=o._getdata_();
end
return false;
end
private
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("data1","int",0xf59a8177),
("data2","short",0x2a0),
("data3","short",0x4019),
("data4","byte[8]",array(0xa3, 0x93, 0xaf, 0x7, 0x9f, 0x9a, 0xb3, 0x62)),
)
);
return SSTRUCT;
end
function __getid(clsid);
begin
//clsid := getmycomregclsid(); //"{F59A8177-02A0-4019-A393-AF079F9AB361}";
@ -389,24 +466,9 @@ type tguid=class(tslcstructureobj)
end
return r;
end
function equ(riid);
begin
if ifarray(riid) then
begin
return _getdata_()=riid ;
end
if riid>0 then
begin
d := _getdata_();
o := new tguid(riid);
return d=o._getdata_();
end
return false;
end
end
type tagVARIANT =class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
begin
@ -428,7 +490,6 @@ type tagVARIANT =class(tslcstructureobj)
end
end
type tagDISPPARAMS = class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
begin
@ -489,7 +550,6 @@ type tagDISPPARAMS = class(tslcstructureobj)
property cArgs index "cArgs" read _getvalue_;
end
type tptrarray =class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
begin
@ -514,74 +574,161 @@ type tptrarray =class(tslcstructureobj)
return sansi;
end
end
type iunkown =class(tslcstructureobj,tcom_const)
uses cstructurelib;
private
static SSTRUCT;
protected
static IID_IUnknown ;//:= new tguid();
static IID_IDispatch;// := new tguid();
m_dwRef;
fvtable;
//////////////////////////vtb/////////////////////////////
type inukownvtbcontainer = class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then
begin
IID_IUnknown := new tguid();
IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
SSTRUCT := MemoryAlignmentCalculate(array(
("vtable","intptr",0)
)
);
end
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
function addref(s:pointer):integer;stdcall;
public
function create(ptr);
begin
inherited create(getstruct(),ptr);
end
end
type iunkown =class(tcom_const)
protected
static IID_IUnknown ;//:= new tguid();
m_dwRef;
fvtable;
fvtablecontainer;
function createvtb(ptr);virtual;
begin
return new inukownvtb(ptr);
end
public
function create(ptr);
begin
if not IID_IUnknown then
begin
IID_IUnknown := new tguid();
IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
end
fvtablecontainer := new inukownvtbcontainer(ptr);
if ptr then
begin
fvtable := createvtb( fvtablecontainer._getvalue_("vtable"));
end else
begin
fvtable := createvtb(nil);
fvtablecontainer._setvalue_("vtable",fvtable._getptr_());
fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
end
end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
begin
if IID_IUnknown.equ(riid) then
begin
ppv := _getptr_();
AddRef(ppv);
return 0;
end
return E_NOINTERFACE;
end
function AddRef(s:pointer):integer;stdcall;virtual;
begin
m_dwRef++;
//echo "\r\nidispath addref:",s,"====",m_dwRef;
return m_dwRef;
end
function release(s:pointer):integer;stdcall;virtual;
function Release(s:pointer):integer;stdcall;virtual;
begin
if m_dwRef>0 then m_dwRef--;
return m_dwRef;
end
end
type dispatchvtable =class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
function _getptr_();
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("QueryInterface","intptr",0),
("AddRef","intptr",0),
("Release","intptr",0),
("GetTypeInfoCount","intptr",0),
("GetTypeInfo","intptr",0),
("GetIDsOfNames","intptr",0),
("Invoke","intptr",0)
)
);
return SSTRUCT;
end
public
return fvtablecontainer._getptr_();
end
end
type idispatch=class(iunkown)
protected
static IID_IDispatch;
function createvtb(ptr);override;
begin
return new idispatchvtb(ptr);
end
public
[weakref] fcom_mgr;
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
end
type idispatch=class(iunkown)
inherited ;//create(getstruct(),ptr);
if not IID_IDispatch then
begin
IID_IDispatch := new tguid();
IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");
end
if not ptr then
begin
fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));
fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));
fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));
fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));
end
frgDispIds := array();
frgDispIds2 := array();
end
function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;virtual;
begin
pctinfo := 0;
return 0;
end
function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;virtual;
begin
if ppTInfo then ppTInfo := 0;
return E_NOTIMPL;
end
function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;virtual;
begin
if cnames>1 then return E_INVALIDARG;
ostr := new tptrarray(rgszNames);
rgDispId := getdispid(ostr.ansistr);
return 0;
end
function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer;
pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;virtual;
begin
o := new tagDISPPARAMS(pDispParams);
pp := o.getArgs();
pms := array();
fname := getdispidstr(dispIdMember);
for idx,p1 in pp do
begin
VariantToObj2(TS_GetGlobalL(),p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
pms[idx] := r;
end
x := fcom_mgr.invoke_call(fname,pms);
ObjToVariantRef(TS_GetGlobalL(),x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
return 0;
end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
begin
if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then
begin
ppv := _getptr_();
addref(ppv);
return 0;
end
return E_NOINTERFACE;
end
function release(s:pointer):integer;stdcall;override;
begin
r := inherited;
if r=0 and fcom_mgr then fcom_mgr.stop_run();
return r;
end
private
frgDispIds;
frgDispIds2;
@ -600,117 +747,16 @@ type idispatch=class(iunkown)
begin
return frgDispIds2[id];
end
protected
static IID_IDispatch;
public
[weakref] fcom_mgr;
function create(ptr)
begin
inherited ;//create(getstruct(),ptr);
if not IID_IDispatch then
begin
IID_IDispatch := new tguid();
IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");
end
if not ptr then
begin
fvtable := new dispatchvtable();
_setvalue_("vtable",fvtable._getptr_());
fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
fvtable._setvalue_("GetTypeInfoCount",makeinstance(thisfunction(GetTypeInfoCount)));
fvtable._setvalue_("GetTypeInfo",makeinstance(thisfunction(GetTypeInfo)));
fvtable._setvalue_("GetIDsOfNames",makeinstance(thisfunction(GetIDsOfNames)));
fvtable._setvalue_("Invoke",makeinstance(thisfunction(Invoke_)));
end else
begin
fvtable := new fvtable(_getvalue_("vtable"));
m_dwRef := 0;
end
frgDispIds := array();
frgDispIds2 := array();
end
function GetTypeInfoCount(s:pointer;var pctinfo:integer):integer;stdcall;
begin
pctinfo := 0;
return 0;
end
function GetTypeInfo(s:pointer;iTInfo:integer;lcid:integer;var ppTInfo:pointer):integer;stdcall;
begin
if ppTInfo then ppTInfo := 0;
return E_NOTIMPL;
end
function GetIDsOfNames(s:pointer;riid:pointer;rgszNames:pointer;cNames:integer;lcid:integer;var rgDispId:integer):integer;stdcall;
begin
if cnames>1 then return E_INVALIDARG;
ostr := new tptrarray(rgszNames);
rgDispId := getdispid(ostr.ansistr);
return 0;
end
function Invoke_(s:pointer;dispIdMember:integer;riid:pointer;lcid:integer;wFlags:short;pDispParams:pointer; pVarResult:pointer;pExcepInfo:pointer;var puArgErr:integer):integer;stdcall;
begin
o := new tagDISPPARAMS(pDispParams);
pp := o.getArgs();
pms := array();
fname := getdispidstr(dispIdMember);
for idx,p1 in pp do
begin
VariantToObj2(TS_GetGlobalL(),p1._getptr_,r,fcom_mgr.invoke_param_is_excel(fname));
pms[idx] := r;
end
x := fcom_mgr.invoke_call(fname,pms);
ObjToVariantRef(TS_GetGlobalL(),x,pVarResult,fcom_mgr.execute_retun_is_excel(fname));
return 0;
end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;
begin
if IID_IUnknown.equ(riid) or IID_IDispatch.equ(riid) then
begin
ppv := _getptr_();
addref(ppv);
return 0;
end
return E_NOINTERFACE;
end
function release(s:pointer):integer;stdcall;override;
begin
r := inherited;
//echo "\r\nidispath release:",s,"====",r;
if r=0 and fcom_mgr then fcom_mgr.stop_run();
return r;
end
end
type ClassFactoryvtable = class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("QueryInterface","intptr",0),
("AddRef","intptr",0),
("Release","intptr",0),
("CreateInstance","intptr",0),
("LockServer","intptr",0)
)
);
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
end
type IClassFactory=class(iunkown)
static sguid;
private
static dwRegister;
static theFactory;
fdispatchs;
static sguid;
protected
static IID_IClassFactory;// := new tguid();
function createvtb(ptr);virtual;
begin
return new iClassFactoryvtb(ptr);
end
public
[weakref] fcom_mgr;
function create(ptr);override;
@ -724,21 +770,11 @@ type IClassFactory=class(iunkown)
fdispatchs := array();
if not ptr then
begin
fvtable := new ClassFactoryvtable();
_setvalue_("vtable",fvtable._getptr_());
fvtable._setvalue_("QueryInterface",makeinstance(thisfunction(QueryInterface)));
fvtable._setvalue_("Release",makeinstance(thisfunction(Release)));
fvtable._setvalue_("AddRef",makeinstance(thisfunction(addref)));
fvtable._setvalue_("CreateInstance",makeinstance(thisfunction(CreateInstance)));
fvtable._setvalue_("LockServer",makeinstance(thisfunction(LockServer)));
end else
begin
fvtable := new fvtable(_getvalue_("vtable"));
m_dwRef := 0;
fvtable._setvalue_("LockServer",makeinstance(thisfunction(LockServer)));
end
end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;override;
begin
if IID_IUnknown.equ(riid) or IID_IClassFactory.equ(riid) then
begin
@ -748,13 +784,8 @@ type IClassFactory=class(iunkown)
end
return E_NOINTERFACE;
end
function release(s:pointer):integer;stdcall;override;
begin
r := inherited;
//echo "\r\nIClassFactory release:",s,"====",r;
return r;
end
function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;//
function CreateInstance(s:pointer;known:pointer;riid:pointer;var ppvObject:pointer):integer;stdcall;virtual;//
begin
if not fdispatchs then
begin
@ -764,60 +795,24 @@ type IClassFactory=class(iunkown)
hr := fdispatchs.QueryInterface(fdispatchs._getptr_(),riid,ppvObject);
return hr;
end
function LockServer(lk:integer):integer;stdcall;
function LockServer(lk:integer):integer;stdcall;virtual;
begin
return 1;
end
end
type trelease = class()
private
[weakref]freleases;
public
function create();
begin
freleases := array();
end
function add(o);
begin
for i,v in freleases do
begin
if o= v then return ;
end
freleases[length(freleases)] := o;
end
function del(o);
begin
for i := 0 to length(freleases)-1 do
begin
if freleases[i]=0 then
begin
return deleteindex(freleases,i,true);
end
end
end
function Destroy();
begin
for i,v in freleases do
begin
if v then
v.Release();
end
freleases := array();
end
private
static dwRegister;
static theFactory;
fdispatchs;
end
type ishelllinkavtable =class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
type ishelllinkavtb = class(inukownvtb)
function create(ptr);
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("QueryInterface","intptr",0),
("AddRef","intptr",0),
("Release","intptr",0),
inherited;
end
protected
function get_vtb_struct();override;
begin
return inherited union array(
("GetPath","intptr",0),
("GetIDList","intptr",0),
("SetIDList","intptr",0),
@ -836,56 +831,42 @@ type ishelllinkavtable =class(tslcstructureobj)
("SetRelativePath","intptr",0),
("Resolve","intptr",0),
("SetPath","intptr",0)
)
);
return SSTRUCT;
end
public
function create(ptr)
end
end
type iPersistFilevtb = class(inukownvtb)
function create(ptr);
begin
inherited create(getstruct(),ptr);
end
end
type iPersistFilevtable =class(tslcstructureobj)
uses cstructurelib;
private
class function getstruct()
inherited;
end
protected
function get_vtb_struct();override;
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("QueryInterface","intptr",0),
("AddRef","intptr",0),
("Release","intptr",0),
return inherited union array(
("GetClassID","intptr",0),
("IsDirty","intptr",0),
("Load","intptr",0),
("Save","intptr",0),
("SaveCompleted","intptr",0),
("GetCurFile","intptr",0)
)
);
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
end
end
type IShellLink=class(tiunkown) //"000214EE-0000-0000-C000-000000000046"
type IShellLink=class(iunkown) //"000214EE-0000-0000-C000-000000000046"
protected
function createvtb(ptr);override;
begin
return new ishelllinkavtb(ptr);
end
public
function create(ptr);override;
begin
inherited ;
fdispatchs := array();
if not ptr then
begin
fvtable := new ishelllinkavtable();
_setvalue_("vtable",fvtable._getptr_());
end else
begin
fvtable := new ishelllinkavtable(_getvalue_("vtable"));
end
end
function Destroy();virtual;
begin
release(nil);
end
function AddRef(s):integer;override;
begin
f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("AddRef");
@ -918,24 +899,36 @@ type IShellLink=class(tiunkown) //"000214EE-0000-0000-C000-000000000046"
if not s then s := _getptr_();
return call(f,s,t);
end
function get_persistfile();
begin
{**
@explan(说明) 获取 文件保存对象 %%
@return(IPersistFile) 对象 %%
**}
fclsid := new tguid();
fclsid.readstr("{0000010b-0000-0000-C000-000000000046}");
if 0<>QueryInterface(nil,fclsid._getptr_(),v2) then
begin
return -1;
end
return new IPersistFile(v2);
end
end
type IPersistFile=class(tiunkown) //"0000010b-0000-0000-C000-000000000046"
type IPersistFile=class(iunkown) //"0000010b-0000-0000-C000-000000000046"
protected
function createvtb(ptr);override;
begin
return new iPersistFilevtb(ptr);
end
public
function create(ptr);override;
begin
inherited ;
fdispatchs := array();
if not ptr then
begin
fvtable := new iPersistFilevtable();
_setvalue_("vtable",fvtable._getptr_());
end else
begin
fvtable := new iPersistFilevtable(_getvalue_("vtable"));
m_dwRef := 0;
end
end
function Destroy();virtual;
begin
Release(nil);
end
function addref(s:pointer):integer;stdcall;override;
begin
ptr := fvtable._getvalue_("AddRef");
@ -988,28 +981,48 @@ type IPersistFile=class(tiunkown) //"0000010b-0000-0000-C000-000000000046"
return call(f,s,fn);
end
end
function create_short_cutA(targ,lnk);//创建文件快捷方式
function sh_get_IShellLinkW(); //获取快捷方式创建接口
begin
if not fileexists("",targ) then return -1;
if not ifstring(lnk) then return -1;
rels := new trelease();
{
@explan(说明) 获取快捷方式构建接口 %%
@return(IShellLink) 接口对象 %%;
}
if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
hd := int64(obj);
aic := new IShellLink(hd);
cls := new tclsguid();
aic.addref();
cls := new tguid();
cls.readstr("{000214F9-0000-0000-C000-000000000046}");
if 0 <> aic.QueryInterface(hd,cls._getptr_(),v) then return -1;
ilink := new IShellLink(v);
rels.add(ilink);
ilink := new IShellLink(v);
return ilink;
end
function create_short_cutA(targ,lnk);//创建文件快捷方式
begin
if not fileexists("",targ) then return -1;
if not ifstring(lnk) then return -1;
ilink := sh_get_IShellLinkW();
if not ifobj(ilink) then return -1;
ilink.SetPath(nil,widestring(targ));
fclsid := new tclsguid();
ifile := ilink.get_persistfile();
return ifile.save(nil,widestring(lnk),true);
///////////////////////////////////////////////////
if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
hd := int64(obj);
aic := new IShellLink(hd);
aic.addref();
cls := new tguid();
cls.readstr("{000214F9-0000-0000-C000-000000000046}");
if 0 <> aic.QueryInterface(hd,cls._getptr_(),v) then return -1;
ilink := new IShellLink(v);
ilink.SetPath(nil,widestring(targ));
fclsid := new tguid();
fclsid.readstr("{0000010b-0000-0000-C000-000000000046}");
if 0<>ilink.QueryInterface(nil,fclsid._getptr_(),v2) then
begin
return -1;
end
ifile := new IPersistFile(v2);
rels.add(ifile);
return ifile.save(nil,widestring(lnk),true);
end
function CoCreateInstance(rclsid:pointer;pUnk:pointer;dwClsContext:integer;riid:integer;var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoCreateInstance";
@ -1027,9 +1040,5 @@ function WideCharToMultiByte(CodePage:integer;dwFlags:integer;lpWideCharStr:poin
lpDefaultChar:pointer;var lpUsedDefaultChar:integer):integer;stdcall;external "Kernel32.dll" name "WideCharToMultiByte";
function MultiByteToWideChar(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;
cchMultiByte:integer;var lpWideCharStr:pointer;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar";
initialization
end.

46
funcext/tvclib/utslvclgdi.tsf
View File

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