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

界面库 

windows程序安装添加快捷方式功能
This commit is contained in:
tslediter 2023-11-24 11:20:09 +08:00
parent 2c2ecaef99
commit 958c17a134
6 changed files with 303 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
editor-install.exe Normal file
View File

Binary file not shown.

292
funcext/tvclib/utslvcl_com.tsf
View File

@ -33,6 +33,25 @@ interface
end
*)
uses tslvcl;
function create_short_cutA(targ,lnk);//创建文件快捷方式
type tiunkown = class(iunkown) //对外输出com接口
function create(ptr)
begin
inherited;
end
end
type tIClassFactory = class(IClassFactory)
function create(ptr)
begin
inherited;
end
end
type tclsguid = class(tguid) //clsid对象
function create(ptr);
begin
inherited;
end
end
type t_com_class = class()
private
theFactory;
@ -502,7 +521,6 @@ type iunkown =class(tslcstructureobj,tcom_const)
static SSTRUCT;
protected
static IID_IUnknown ;//:= new tguid();
static IID_IClassFactory;// := new tguid();
static IID_IDispatch;// := new tguid();
m_dwRef;
fvtable;
@ -511,11 +529,10 @@ type iunkown =class(tslcstructureobj,tcom_const)
if not SSTRUCT then
begin
IID_IUnknown := new tguid();
IID_IClassFactory := new tguid();
IID_IDispatch := new tguid();
IID_IUnknown.readstr("{00000000-0000-0000-C000-000000000046}");
IID_IClassFactory.readstr("{00000001-0000-0000-C000-000000000046}");
IID_IDispatch.readstr("{00020400-0000-0000-C000-000000000046}");
SSTRUCT := MemoryAlignmentCalculate(array(
("vtable","intptr",0)
@ -583,11 +600,18 @@ type idispatch=class(iunkown)
begin
return frgDispIds2[id];
end
public
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();
@ -684,12 +708,19 @@ type IClassFactory=class(iunkown)
private
static dwRegister;
static theFactory;
fdispatchs;
fdispatchs;
protected
static IID_IClassFactory;// := new tguid();
public
[weakref] fcom_mgr;
function create(ptr);override;
begin
inherited ;
if not IID_IClassFactory then
begin
IID_IClassFactory := new tguid();
IID_IClassFactory.readstr("{00000001-0000-0000-C000-000000000046}");
end
fdispatchs := array();
if not ptr then
begin
@ -707,7 +738,7 @@ type IClassFactory=class(iunkown)
m_dwRef := 0;
end
end
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;
function QueryInterface(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;virtual;
begin
if IID_IUnknown.equ(riid) or IID_IClassFactory.equ(riid) then
begin
@ -738,9 +769,252 @@ type IClassFactory=class(iunkown)
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
end
type ishelllinkavtable =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),
("GetPath","intptr",0),
("GetIDList","intptr",0),
("SetIDList","intptr",0),
("GetDescription","intptr",0),
("SetDescription","intptr",0),
("GetWorkingDirectory","intptr",0),
("SetWorkingDirectory","intptr",0),
("GetArguments","intptr",0),
("SetArguments","intptr",0),
("GetHotkey","intptr",0),
("SetHotkey","intptr",0),
("GetShowCmd","intptr",0),
("SetShowCmd","intptr",0),
("GetIconLocation","intptr",0),
("SetIconLocation","intptr",0),
("SetRelativePath","intptr",0),
("Resolve","intptr",0),
("SetPath","intptr",0)
)
);
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
end
type iPersistFilevtable =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),
("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
type IShellLink=class(tiunkown) //"000214EE-0000-0000-C000-000000000046"
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 AddRef(s):integer;override;
begin
f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("AddRef");
if not s then s := _getptr_();
return call(f,_getptr_());
end
function Release(s):integer;override;
begin
f := function(s:pointer):integer;stdcall;external fvtable._getvalue_("Release"); ;
if not s then s := _getptr_();
return call(f,s);
end
function QueryInterface(s,riid,ppv):integer;virtual;
begin
f := function(s:pointer;riid:pointer;var ppv:pointer):integer;stdcall;external fvtable._getvalue_("QueryInterface");;
if not s then s := _getptr_();
return call(f,s,riid,ppv);
end
function SetPath(s:pointer;target:widestring):integer;stdcall;virtual;
begin
ptr := fvtable._getvalue_("SetPath");
f := function(s:pointer;target:widestring):integer;stdcall ;external ptr;
if not s then s := _getptr_();
R := ##f(s,target);
RETURN R;
end
function SetDescription(s:pointer;descrip:widestring):integer;stdcall;virtual;
begin
f := function(s:pointer;descrip:widestring):integer;stdcall;external fvtable._getvalue_("SetDescription");
if not s then s := _getptr_();
return call(f,s,t);
end
end
type IPersistFile=class(tiunkown) //"0000010b-0000-0000-C000-000000000046"
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 addref(s:pointer):integer;stdcall;override;
begin
ptr := fvtable._getvalue_("AddRef");
f := function(s:pointer):integer;stdcall;external ptr;
if not s then s := _getptr_();
return call(f,s);
end
function Release(s:pointer):integer;stdcall;override;
begin
ptr := fvtable._getvalue_("AddRef");
f := function(s:pointer):integer;stdcall;external ptr;
if not s then s := _getptr_();
return call(f,s);
end
function IsDirty(s:pointer):integer;stdcall;virtual;
begin
ptr := fvtable._getvalue_("IsDirty");
f := function(s:pointer):integer;stdcall;external ptr;
if not s then s := _getptr_();
return call(f,s);
end
function Load(s:pointer;fn:widestring;md:integer):integer;stdcall;virtual;
begin
ptr := fvtable._getvalue_("Load");
f := function(s:pointer;fn:string;dwmode:integer):integer;stdcall;external ptr;
if not s then s := _getptr_();
return call(f,s,fn,md);
end
function Save(s:pointer;fn:widestring;Remember:integer):integer;stdcall;virtual;
begin
ptr := fvtable._getvalue_("Save");
f := function(s:pointer;fn:widestring;remember:integer):integer;stdcall;external ptr;
if not s then s := _getptr_();
r := call(f,s,fn,Remember);
return r;
end
function SaveCompleted(s:pointer;fn:widestring);
begin
ptr := fvtable._getvalue_("SaveCompleted");
f := function(s:pointer;fn:widestring):integer;stdcall;external ptr;
if not s then s := _getptr_();
return call(f,s,fn);
end
function GetCurFile(s:pointer;fn:widestring);
begin
ptr := fvtable._getvalue_("GetCurFile");
f := function(fn:pointer):integer;stdcall;external ptr;
if not s then s := _getptr_();
return call(f,s,fn);
end
end
function create_short_cutA(targ,lnk);//创建文件快捷方式
begin
if not fileexists("",targ) then return -1;
if not ifstring(lnk) then return -1;
rels := new trelease();
if 1<>createcomobject("{00021401-0000-0000-C000-000000000046}",obj) then return -1;
hd := int64(obj);
aic := new IShellLink(hd);
cls := new tclsguid();
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.SetPath(nil,widestring(targ));
fclsid := new tclsguid();
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";
function CoRegisterClassObject(rclsid:pointer;pUnk:pointer;dwClsContext:integer;flags:integer;var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRegisterClassObject";
function CoRevokeClassObject(var lpdwRegister:integer):integer; stdcall; external "ole32.dll" name "CoRevokeClassObject";
function WSAStartup(q:short;d:pointer):integer; stdcall; external "Ws2_32.dll" name "WSAStartup";
function CoInitializeEx(q:pointer;d:integer):integer; stdcall; external "ole32.dll" name "CoInitializeEx";
@ -751,6 +1025,8 @@ function uaw_wcslen(s:pointer):integer;stdcall;external "Kernel32.dll" name "uaw
function WideCharToMultiByte(CodePage:integer;dwFlags:integer;lpWideCharStr:pointer;
cchWideChar:integer;var lpMultiByteStr:string;cbMultiByte:integer;
lpDefaultChar:pointer;var lpUsedDefaultChar:integer):integer;stdcall;external "Kernel32.dll" name "WideCharToMultiByte";
function MultiByteToWideChar(CodePage:integer;dwFlags:integer;lpMultiByteStr:string;
cchMultiByte:integer;var lpWideCharStr:pointer;cchWideChar:integer):integer;stdcall;external "Kernel32.dll" name "MultiByteToWideChar";

17
funcext/tvclib/utslvclinstall.tsf
View File

@ -45,6 +45,16 @@ type t_tsl_window_reg = class()
reg.SetValueStringA("InstallTime",datetimetostr(now()));
return install_info_setex(reg);
end
function createshortcut();virtual;
begin
uses utslvcl_com;
wapi := initializeapplication()._wapi;
path := "";
setlength(path,1024);
if not wapi.SHGetSpecialFolderPathA(0,path,2,0) then return -1;
sn := gets(path)+"\\"+getdisplayname()+".lnk";
return create_short_cutA(fexe,sn);
end
function install_info_setex(reg);virtual; //写入额外信息
begin
return 0;
@ -139,6 +149,13 @@ type t_tsl_window_reg = class()
fdefaultexedir;
finstallforall;
private
function gets(s);
begin
for i:= 1 to length(s) do
begin
if s[i]="\0" then return s[1:(i-1)];
end
end
function setexename(s);
begin
if ifstring(s) and s and (s<>fexename) and not(pos("\\",s)) then

2
funcext/tvclib/uwindowsinterface.tsf
View File

@ -681,6 +681,8 @@ type twindowsapi = class()
function ChooseFontA(LOGFONTA:pointer):integer;stdcall;external "Comdlg32.dll" name "ChooseFontA";
function ChooseColorA(LOGFONTA:pointer):integer;stdcall;external "Comdlg32.dll" name "ChooseColorA";
//************************************
function SHGetSpecialFolderPathA(hwnd:pointer;var path:string;csidl:integer;ifcreate:integer):integer;stdcall;external "Shell32.dll" name "SHGetSpecialFolderPathA";
function Shell_NotifyIconA(dwMessage:integer; lpData:pointer):integer;stdcall;external "Shell32.dll" name "Shell_NotifyIconA";
function ILCreateFromPathA(pszPath:string):pointer;stdcall;external "Shell32.dll" name "ILCreateFromPathA";
procedure ILFree(pidl:pointer);stdcall;external "Shell32.dll" name "ILFree";

1
tsleditor卸载.cmd
View File

@ -1 +0,0 @@
"%~dp0tsleditor.exe" -uninstall

1
tsleditor注册.cmd
View File

@ -1 +0,0 @@
"%~dp0tsleditor.exe" -install