界面库

windows程序安装添加快捷方式功能

funcext/tvclib/utslvcl_com.tsf

@@ -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 
+    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();
@@ -685,11 +709,18 @@ type IClassFactory=class(iunkown)
     static dwRegister;    
     static theFactory;
     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 
@@ -739,8 +770,251 @@ type IClassFactory=class(iunkown)
     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";
 
 
 

funcext/tvclib/utslvclinstall.tsf

@@ -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 

funcext/tvclib/uwindowsinterface.tsf

@@ -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";

tsleditor卸载.cmd

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

tsleditor注册.cmd

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