diff --git a/designer/utslcodeeditor.tsf b/designer/utslcodeeditor.tsf index a01da1a..1b8e7a1 100644 --- a/designer/utslcodeeditor.tsf +++ b/designer/utslcodeeditor.tsf @@ -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 diff --git a/designer/utslcodeformat.tsf b/designer/utslcodeformat.tsf index ec20836..7e0d674 100644 --- a/designer/utslcodeformat.tsf +++ b/designer/utslcodeformat.tsf @@ -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 diff --git a/editor-install.exe b/editor-install.exe index f59366f..c964e16 100644 Binary files a/editor-install.exe and b/editor-install.exe differ diff --git a/funcext/tvclib/tgdiplusflat.tsf b/funcext/tvclib/tgdiplusflat.tsf index f75bca1..d597b00 100644 --- a/funcext/tvclib/tgdiplusflat.tsf +++ b/funcext/tvclib/tgdiplusflat.tsf @@ -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); diff --git a/funcext/tvclib/utslvcl_com.tsf b/funcext/tvclib/utslvcl_com.tsf index e1c8aa6..f6fa868 100644 --- a/funcext/tvclib/utslvcl_com.tsf +++ b/funcext/tvclib/utslvcl_com.tsf @@ -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. \ No newline at end of file diff --git a/funcext/tvclib/utslvclgdi.tsf b/funcext/tvclib/utslvclgdi.tsf index e6a541b..2b40252 100644 --- a/funcext/tvclib/utslvclgdi.tsf +++ b/funcext/tvclib/utslvclgdi.tsf @@ -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(说明)光标类 %%