Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
How do I create a Desktop icon for my application when it runs Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
29-Aug-02
Category
Shell API
Language
Delphi All Versions
Views
105
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			Author: Tomas Rutkauskas 

How do I create a Desktop icon for my application when it runs?

Answer:

Solve 1:

This is a unit to create a link in any folder you want, including the Windows 
Desktop:

1   unit ShellLink;
2   
3   uses
4     SysUtils, ShlObj, OLE2, Windows, Registry;
5   
6   interface
7   procedure OLECheck(OleRetVal: HResult);
8   function GetShellLink: IShellLink;
9   function GetFolderLocation(const FolderType: string): string;
10  function ChangeFileExt(FileName, Ext: string): string;
11  function CreateLink(const AppName, LinkName, Desc, Dest: string): string;
12  
13  implementation
14  
15  procedure OLECheck(OleRetVal: HResult);
16  {Checks the HResult return value of an OLE function.  Raises an exception if value 
17  is
18  something other than S_OK. }
19  const
20    OleErrStr = 'OLE function call failed. HResult is $%x. GetLastError is $%x';
21  begin
22    if OleRetVal <> S_OK then
23      raise EShellOleError.CreateFmt(OleErrStr, [OleRetVal, GetLastError]);
24  end;
25  
26  function GetShellLink: IShellLink;
27  { Returns reference to ISHellLink object }
28  begin
29    OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
30      IID_IShellLink, Result));
31  end;
32  
33  function GetFolderLocation(const FolderType: string): string;
34  { Retrieves from registry path to folder indicated in FolderType }
35  var
36    Reg: TRegistry;
37  begin
38    Reg := TRegistry.Create;
39    try
40      with Reg do
41      begin
42        RootKey := HKEY_CURRENT_USER;
43        if not OpenKey(SFolderKey, False) then
44          { Open key where shell folder information is kept }
45          raise ERegistryException.CreateFmt('Folder key "%s" not found', 
46  [SFolderKey]);
47        { Get path for specified folder }
48        Result := ReadString(FolderType);
49        if Result = '' then
50          raise ERegistryException.CreateFmt('"%s" item not found in registry',
51            [FolderType]);
52        CloseKey;
53      end;
54    finally
55      Reg.Free;
56    end;
57  end;
58  
59  function ChangeFileExt(FileName, Ext: string): string;
60  var
61    aFn: string;
62  begin
63    aFn := ExtractFileName(FileName);
64    delete(aFn, length(aFn) - 2, 3);
65    aFn := aFn + Ext;
66    Result := aFn;
67  end;
68  
69  function CreateLink(const AppName, LinkName, Desc, Dest: string): string;
70  { Creates a shell link for application or document specified in AppName with 
71  description Desc. Link will be located in folder specified by Dest, which is one of 
72  the string constants shown at the top of this unit. Returns the full path name of 
73  the link file. }
74  var
75    SL: IShellLink;
76    PF: IPersistFile;
77    LnkName: string;
78    WStr: array[0..MAX_PATH - 1] of WideChar;
79  begin
80    SL := GetShellLink;
81    try
82      { The IShellLink Interface supports the IPersistFile interface. Get an 
83  interface pointer to it. }
84      OleCheck(SL.QueryInterface(IID_IPersistFile, PF));
85      try
86        OleCheck(SL.SetPath(PChar(AppName))); {set link path to proper file}
87        if Desc <> '' then
88          OleCheck(SL.SetDescription(PChar(Desc))); {set description}
89        { create a path location and filename for link file }
90        LnkName := Dest + '\' + linkName;
91        { If you want to create a link to"Desktop", you must call 
92  GetFolderLocation('Desktop') }
93        { convert the link file pathname to a PWideChar }
94        StringToWideChar(LnkName, WStr, MAX_PATH);
95        PF.Save(WStr, True); {save link file}
96      finally
97        PF.Release;
98      end;
99    finally
100     SL.Release;
101   end;
102   Result := LnkName;
103 end;
104 initialization
105   OleInitialize(nil);
106 finalization
107   OleUninitialize;
108 
109 //Example:
110 
111 uses
112   shellLink;
113 
114 var
115   lnkName: string;
116   FileToInstall: string;
117   LinkFile: string;
118   comment: string;
119   Dest: string; { destination's folder }
120 begin
121   FileToInstall := 'Example.exe';
122   LinkFile := 'Example.lnk';
123   Comment := 'Link to Example.exe';
124   Dest := GetFolderLocation('Desktop')
125     lnkName := CreateLink(FileToInstall, LinkFile, Comment, Dest);
126 end;



Solve 2:

127 uses
128   Registry, ShlObj, ActiveX, ComObj;
129 
130 type
131   ShortcutType = (_DESKTOP, _STARTMENU);
132 
133 procedure CreateShortcut(FileName: string; Location: ShortcutType);
134 var
135   MyObject: IUnknown;
136   MySLink: IShellLink;
137   MyPFile: IPersistFile;
138   Directory, LinkName: string;
139   WFileName: WideString;
140   MyReg: TRegIniFile;
141 begin
142   MyObject := CreateComObject(CLSID_ShellLink);
143   MySLink := MyObject as IShellLink;
144   MyPFile := MyObject as IPersistFile;
145   MySLink.SetPath(PChar(FileName));
146   MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
147   try
148     LinkName := ChangeFileExt(FileName, '.lnk');
149     LinkName := ExtractFileName(LinkName);
150     if Location = _DESKTOP then
151     begin
152       {Use the next line of code to put the shortcut on your desktop}
153       Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
154       WFileName := Directory + '\' + LinkName;
155       MyPFile.Save(PWChar(WFileName), False);
156     end;
157     if Location = _STARTMENU then
158     begin
159       {Use the next two lines to put the shortcut on your start menu}
160       Directory := MyReg.ReadString('Shell Folders', 'Start Menu', '');
161       CreateDir(Directory);
162       WFileName := Directory + '\' + LinkName;
163       MyPFile.Save(PWChar(WFileName), False);
164     end;
165   finally
166     MyReg.Free;
167   end;
168 end;



Solve 3:
169 
170 { uses ShlObj, ActiveX, ComObj, SysUtils, etc... }
171 { "DestFolder" should be one of the CSIDL_ constants as declared in the ShlObj unit 
172 }
173 
174 procedure CreateProgramShortcut(DestFolder: Integer; const Applic: string);
175 var
176   SL: IShellLink;
177   PF: IPersistFile;
178   LnkName: WideString;
179   FP: array[0..MAX_PATH * 2] of Char;
180   IDL: PItemIDList;
181 begin
182   CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, SL);
183   PF := SL as IPersistFile;
184   { Make shortcut point to Application.Exename }
185   SL.SetPath(PChar(Applic));
186   { Set input paramters (if any) }
187   { Set default directory to exe-file's location }
188   SL.SetWorkingDirectory(PChar(ExtractFilePath(Applic)));
189   { Use the exe-file's icon }
190   SL.SetIconLocation(PChar(Applic), 0);
191   { Just leaving the following fields empty for now. Could be adjusted if the 
192 customer must have these set }
193   SL.SetArguments('');
194   SL.SetDescription('');
195   SL.SetShowCmd(0);
196   SL.SetHotKey(0);
197   { Resolve the path-name of the special folder }
198   if SHGetSpecialFolderLocation(0, DestFolder, IDL) = NOERROR then
199     SHGetPathFromIDList(IDL, FP);
200   { save the file as "Exename.lnk" }
201   LnkName := WideString(FP) + '\' + ExtractFilename(ChangeFileExt(Applic, '.lnk'));
202   PF.Save(PWideChar(LnkName), True);
203 end;
204 
205 {Now you can just paste this procedure into your project and then, the only thing 
206 to do is to call something like this:}
207 
208 { Create a shortcut to current exe on the desktop }
209 CreateProgramShortcut(CSIDL_DESKTOP, ParamStr(0));
210 { Create a shortcut to notepad in the start-menu }
211 CreateProgramShortcut(CSIDL_STARTMENU, 'c:\windwos\notepad.exe');


Solve 4:

Following code originates from a DragDrop demo of Angus Johnson and Anders Melander:

212 uses
213   ActiveX, ShlObj, ComObj;
214 
215 {Create a file link}
216 
217 function CreateLink(SourceFile, ShortCutName: string): string;
218 var
219   IUnk: IUnknown;
220   ShellLink: IShellLink;
221   IPFile: IPersistFile;
222   tmpShortCutName: string;
223   WideStr: WideString;
224   i: integer;
225 begin
226   IUnk := CreateComObject(CLSID_ShellLink);
227   ShellLink := IUnk as IShellLink;
228   IPFile := IUnk as IPersistFile;
229   with ShellLink do
230   begin
231     SetPath(PChar(SourceFile));
232     SetWorkingDirectory(PChar(ExtractFilePath(SourceFile)));
233   end;
234   ShortCutName := ChangeFileExt(ShortCutName, '.lnk');
235   if FileExists(ShortCutName) then
236   begin
237     ShortCutName := Copy(ShortCutName, 1, Length(ShortCutName) - 4);
238     i := 1;
239     repeat
240       tmpShortCutName := ShortCutName + '(' + IntToStr(i) + ').lnk';
241       Inc(i);
242     until
243       not FileExists(tmpShortCutName);
244     Result := tmpShortCutName;
245   end
246   else
247     Result := ShortCutName;
248   WideStr := Result;
249   IPFile.Save(PWChar(WideStr), False);
250 end;


Usage is similar as with CopyFile but instead of actual copying it, it creates a 
shortcut to the sourcefile.

CreateLink('c:\apath\afile.ext', 'c:\anotherpath\afile.ext');


Solve 5:
251 
252 {Shortcut Component for Delphi 2.0 by Elliott Shevin, Oak Park, Mich. USA
253 April, 1999
254 email: shevine@aol.com
255 version 1.1.
256 
257 Includes the following corrections:
258 The Write method doesn't set a hot key if that property is not greater than space.
259 The correct values are used for ShowCmd.
260 
261 This component incorporates the shortcut read function of TShellLink by Radek Voltr 
262 with shortcut creation code from Jordan Russell, who merits special thanks for 
263 reviewing and improving the code.
264 
265 This is a freeware component. Use it any way you like, but please report errors and 
266 improvements to me, and acknowledge Radek and Jordan.}
267 unit ShortcutLink;
268 
269 {$IFNDEF VER80}{$IFNDEF VER90}{$IFNDEF VER93}
270 {$DEFINE Delphi3orHigher}
271 {$ENDIF}{$ENDIF}{$ENDIF}
272 
273 interface
274 
275 uses
276   Windows, Messages, SysUtils, Classes, Forms,
277 {$IFNDEF Delphi3orHigher}
278   OLE2,
279 {$ELSE}
280   ActiveX, ComObj,
281 {$ENDIF}
282   ShellAPI, ShlObj, CommCtrl, StdCtrls;
283 
284 const
285   SLR_NO_UI = $0001;
286   SLR_ANY_MATCH = $0002;
287   SLR_UPDATE = $0004;
288   SLGP_SHORTPATH = $0001;
289   SLGP_UNCPRIORITY = $0002;
290   Error_Message = 'Unable to create .lnk file';
291 {$IFDEF Delphi3orHigher}
292   IID_IPersistFile: TGUID = (D1: $0000010B; D2: $0000; D3: $0000;
293     D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
294 {$ENDIF}
295 
296 type
297   EShortcutError = class(Exception);
298   TShowCmd = (scShowMaximized, scShowMinimized, scShowNormal);
299 
300 type
301   TShortcutLink = class(TComponent)
302   private
303     { Private declarations }
304   protected
305     { Protected declarations }
306     fShortcutFile, fTarget, fWorkingDir, fDescription, fArguments, fIconLocation:
307       string;
308     fIconNumber, fHotKey: Word;
309     fShowCmd: integer;
310     procedure fSetHotKey(c: string);
311     function fGetHotKey: string;
312     procedure fSetShowCmd(c: TShowCmd);
313     function fGetShowCmd: TShowCmd;
314     function fGetDesktopFolder: string;
315     function fGetProgramsFolder: string;
316     function fGetStartFolder: string;
317     function fGetStartupFolder: string;
318     function fGetSpecialFolder(nFolder: integer): string;
319   public
320     { Public declarations }
321     procedure read;
322     procedure write;
323     property DesktopFolder: string read fGetDesktopFolder;
324     property ProgramsFolder: string read fGetProgramsFolder;
325     property StartFolder: string read fGetStartFolder;
326     property StartupFolder: string read fGetStartupFolder;
327   published
328     { Published declarations }
329     property ShortcutFile: string read fShortcutFile write fShortcutFile;
330     property Target: string read fTarget write fTarget;
331     property WorkingDir: string read fWorkingDir write fWorkingDir;
332     property Description: string read fDescription write fDescription;
333     property Arguments: string read fArguments write fArguments;
334     property IconLocation: string read fIconLocation write fIconLocation;
335     property HotKey: string read fGetHotKey write fSetHotKey;
336     property ShowCmd: TShowCmd read fGetShowCmd write fSetShowCmd default
337       scShowNormal;
338     property IconNumber: Word read fIconNumber write fIconNumber;
339   end;
340 
341 procedure register;
342 
343 implementation
344 
345 procedure register;
346 begin
347   RegisterComponents('Win95', [TShortcutLink]);
348 end;
349 
350 {This is the Read method, which reads the link to which fShortcutFile points. It 
351 was SetSelfPath in Radek Voltr's TShellLink component, where setting the 
352 ShortcutFile property caused the shortcut file to be read immediately.}
353 
354 procedure TShortcutLink.read;
355 var
356   X3: PChar;
357   hresx: HResult;
358   Psl: IShellLink;
359   Ppf: IPersistFile;
360   Saver: array[0..Max_Path] of WideChar;
361   X1: array[0..MAX_PATH - 1] of Char;
362   Data: TWin32FindData;
363   I, Y: Integer;
364   W: Word;
365 begin
366   hresx := CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
367 {$IFDEF Delphi3orHigher}IID_IShellLinkA
368 {$ELSE}IID_IShellLink
369 {$ENDIF}, psl);
370   if hresx <> 0 then
371     Exit;
372   hresx := psl.QueryInterface(IID_IPersistFile, ppf);
373   if hresx <> 0 then
374     Exit;
375   X3 := StrAlloc(MAX_PATH);
376   StrPCopy(X3, fShortcutFile);
377   MultiByteToWideChar(CP_ACP, 0, X3, -1, Saver, Max_Path);
378   hresx := ppf.Load(Saver, STGM_READ);
379   if hresx <> 0 then
380   begin
381     raise EShortcutError.Create('Unable to open link file');
382     Exit;
383   end;
384   hresx := psl.Resolve(0, SLR_ANY_MATCH);
385   if hresx <> 0 then
386     Exit;
387   hresx := psl.GetWorkingDirectory(@X1, MAX_PATH);
388   if hresx <> 0 then
389   begin
390     raise EShortcutError.Create('Error in getting WorkingDir');
391     Exit;
392   end;
393   fWorkingDir := StrPas(@X1);
394   hresx := psl.GetPath(@X1, MAX_PATH, Data, SLGP_UNCPRIORITY);
395   if hresx <> 0 then
396   begin
397     raise EShortcutError.Create('Error in getting Target');
398     Exit;
399   end;
400   fTarget := StrPas(@X1);
401   hresx := psl.GetIconLocation(@X1, MAX_PATH, I);
402   if hresx <> 0 then
403   begin
404     raise EShortcutError.Create('Error in getting icon data');
405     Exit;
406   end;
407   fIconLocation := StrPas(@X1);
408   fIconNumber := I;
409   hresx := psl.GetDescription(@X1, MAX_PATH);
410   if hresx <> 0 then
411   begin
412     raise EShortcutError.Create('Error in get Description');
413     Exit;
414   end;
415   fDescription := StrPas(@X1);
416   Y := 0;
417   hresx := psl.GetShowCmd(Y);
418   if hresx <> 0 then
419   begin
420     raise EShortcutError.Create('Error in getting ShowCmd');
421     Exit;
422   end;
423   fShowCmd := Y;
424   W := 0;
425   hresx := psl.GetHotKey(W);
426   if hresx <> 0 then
427   begin
428     raise EShortcutError.Create('Error in geting HotKey');
429     Exit;
430   end;
431   fHotKey := W;
432   if fHotKey = 0 then
433     HotKey := ' '
434   else
435     HotKey := chr(fHotKey);
436   hresx := psl.GetArguments(@X1, MAX_PATH);
437   if hresx <> 0 then
438   begin
439     raise EShortcutError.Create('Error in getting Arguments');
440     Exit;
441   end;
442   fArguments := StrPas(@X1);
443 {$IFNDEF Delphi3orHigher}
444   ppf.release;
445   psl.release;
446 {$ENDIF}
447   StrDispose(X3);
448 end;
449 
450 {The Write method is adapted from code in Jordan Russell's Inno Setup.}
451 
452 procedure TShortcutLink.write;
453 var
454   aISL: IShellLink;
455   aIPF: IPersistFile;
456 {$IFNDEF Delphi3OrHigher}
457   aPidl: PItemIDList;
458   WideFilename: array[0..MAX_PATH - 1] of WideChar;
459 {$ELSE}
460   Obj: IUnknown;
461   WideFilename: WideString;
462 {$ENDIF}
463 begin
464   {Get an IShellLink interface to make the shortcut. The methods differ between
465   Delphi 2 and later releases.}
466 
467 {$IFNDEF Delphi3OrHigher}
468   if not SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
469     IID_IShellLink, aISL)) then
470     raise EShortcutError.Create(Error_Message);
471 {$ELSE}
472   Obj := CreateComObject(CLSID_ShellLink);
473   aiSL := Obj as IShellLink;
474 {$ENDIF}
475 
476   try
477     {Now we have an IShellLink interface, so we can set it up as we like. Set the 
478 target.}
479     aISL.SetPath(Pchar(fTarget));
480     {Set the working directory ("Start in")}
481     aISL.SetWorkingDirectory(PChar(fWorkingDir));
482     {Set the command-line params}
483     aISL.SetArguments(Pchar(fArguments));
484     {Set the description}
485     aISL.SetDescription(Pchar(fDescription));
486     {Set the show command}
487     aISL.SetShowCmd(fShowCmd);
488     {Set the hotkey}
489     {Vers. 1.1 avoids this command if fHotKey isn't greater than a space.}
490     if fHotKey > ord(' ') then
491       aISL.SetHotKey(((HOTKEYF_ALT or HOTKEYF_CONTROL) shl 8) or fHotKey);
492     {Set the icon location}
493     aISL.SetIconLocation(Pchar(fIconLocation), fIconNumber);
494     {The shortcut IShellLink is now all set up. We get an IPersistFile interface 
495 from it, and use it to save the link. Delphi 2 differs from later releases.}
496 
497 {$IFNDEF Delphi3OrHigher}
498     if aISL.QueryInterface(IID_IPersistFile, aIPF) <> S_OK then
499       raise EShortcutError.Create(Error_Message)
500     else
501       MultiByteToWideChar(CP_ACP, 0, PChar(fShortcutFile), -1, WideFilename,
502         MAX_PATH);
503 {$ELSE}
504     aiPF := Obj as IPersistFile;
505     WideFilename := fShortcutFile;
506 {$ENDIF}
507 
508     try
509 {$IFNDEF Delphi3OrHigher}
510       if aIPF.Save(WideFilename, True) <> S_OK
511 {$ELSE}
512       if aIPF.Save(PWideChar(WideFilename), True) <> S_OK
513 {$ENDIF} then
514         raise EShortcutError.Create(Error_Message);
515     finally
516 {$IFNDEF Delphi3OrHigher}
517       aIPF.Release; {Only needed for D2--later releases do this implicitly.}
518 {$ENDIF}
519     end;
520 
521   finally
522 {$IFNDEF Delphi3OrHigher}
523     aISL.Release; {Only needed for D2--later releases do this implicitly.}
524 {$ENDIF}
525   end;
526 end;
527 
528 function TShortcutLink.fGetDesktopFolder: string;
529 begin
530   result := fGetSpecialFolder(CSIDL_DESKTOPDIRECTORY);
531 end;
532 
533 function TShortcutLink.fGetProgramsFolder: string;
534 begin
535   result := fGetSpecialFolder(CSIDL_PROGRAMS);
536 end;
537 
538 function TShortcutLink.fGetStartFolder: string;
539 begin
540   result := fGetSpecialFolder(CSIDL_STARTMENU);
541 end;
542 
543 function TShortcutLink.fGetStartupFolder: string;
544 begin
545   result := fGetSpecialFolder(CSIDL_STARTUP);
546 end;
547 
548 function TShortcutLink.fGetSpecialFolder(nFolder: integer): string;
549 var
550   aPidl: PItemIDList;
551   handle: THandle;
552   TC: TComponent;
553   fLinkDir: string;
554 begin
555   {Get the folder location (as a PItemIDList)}
556   TC := self.owner;
557   handle := (TC as TForm).handle;
558   if SUCCEEDED(SHGetSpecialFolderLocation(handle, nFolder, aPidl)) then
559   begin
560     {Get the actual path of the desktop directory from the PItemIDList}
561     SetLength(fLinkDir, MAX_PATH); {SHGetPathFromIDList assumes MAX_PATH buffer}
562     SHGetPathFromIDList(aPidl, PChar(fLinkDir)); {Do it}
563     SetLength(fLinkDir, StrLen(PChar(fLinkDir)));
564     result := fLinkDir;
565   end;
566 end;
567 
568 procedure TShortcutLink.fSetHotKey(c: string);
569 var
570   s: string[1];
571   c2: char;
572 begin
573   s := c;
574   if length(c) < 1 then
575     s := ' ';
576   s := uppercase(s);
577   c2 := s[1];
578   if ord(c2) < ord(' ') then
579     c2 := ' ';
580   fHotKey := ord(c2);
581 end;
582 
583 function TShortcutLink.fGetHotKey: string;
584 begin
585   if fHotKey = 0 then
586     fHotKey := ord(' ');
587   result := chr(fHotKey);
588 end;
589 
590 procedure TShortcutLink.fSetShowCmd(c: TShowCmd);
591 begin
592   case c of
593     scSHOWMAXIMIZED: fShowCmd := SW_Maximize;
594     scSHOWMINIMIZED: fShowCmd := SW_ShowMinNoActive;
595     scSHOWNORMAL: fShowCmd := SW_Restore;
596   end;
597 end;
598 
599 function TShortcutLink.fGetShowCmd: TShowCmd;
600 begin
601   case fShowCmd of
602     SW_MAXIMIZE: result := scShowMaximized;
603     SW_SHOWMINNOACTIVE: result := scShowMinimized;
604     SW_RESTORE: result := scShowNormal;
605   else
606     result := scShowNormal;
607   end;
608 end;
609 
610 initialization
611   CoInitialize(nil); {Must initialize COM or CoCreateInstance won't work}
612 finalization
613   CoUninitialize; {Symmetric uninitialize}
614 
615 end.



Solve 6:
616 
617 function CreateShellLink(sEintrag, sExeFile, sParams, sIconFile: string; iIconNr:
618   Integer;
619   const sDescription: string): HRESULT;
620 {create ShellLink, overwrite if already exist}
621 var
622   hrInit: HRESULT;
623   pIShellLink: IShellLink;
624   pIPersistFile: IPersistFile;
625 begin
626   result := E_FAIL;
627   {they should be NIL}
628   Assert((nil = pIShellLink) and (nil = pIPersistFile));
629   {parameter test}
630   Assert((sEintrag <> '') and (sExeFile <> ''));
631   if (sEintrag = '') or (sExeFile = '') then
632     Exit;
633   {action}
634   hrInit := CoInitialize(nil);
635   try
636     result := hrInit;
637     if FAILED(result) then
638       Exit;
639     {Get a pointer to the IShellLink interface}
640     result := CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,
641       IID_IShellLinkA, pIShellLink);
642     if FAILED(result) then
643       Exit;
644     {Set the path to the shortcut target and the params}
645     pIShellLink.SetPath(PChar(sExeFile));
646     pIShellLink.SetArguments(PChar(sParams));
647     {add description and icon}
648     if sDescription <> '' then
649       pIShellLink.SetDescription(PChar(sDescription));
650     if sIconFile <> '' then
651       pIShellLink.SetIconLocation(PChar(sIconFile), iIconNr);
652     {Query IShellLink for the IPersistFile interface for saving the shortcut in 
653 persistent storage}
654     result := pIShellLink.QueryInterface(IID_IPersistFile, pIPersistFile);
655     if FAILED(result) then
656       Exit;
657     {Ensure that the string is OLECHAR
658     Ensure that the new link has the .LNK extension
659     Save the link by calling IPersistFile::Save.}
660     if CompareText(ExtractFileExt(sEintrag), '.lnk') <> 0 then
661       sEintrag := sEintrag + '.lnk';
662     ForceDirectories(ExtractFilePath(sEintrag));
663     result := pIPersistFile.Save(PWideChar(WideString(sEintrag)), True);
664   finally
665     pIShellLink := nil;
666     pIPersistFile := nil;
667     if SUCCEEDED(hrInit) then
668       CoUninitialize;
669   end;
670 end;



Solve 7:

671 uses
672   ComObj, ShlObj, ActiveX;
673 
674 procedure CreateShortcut(AFileName: string; ALocation: string);
675 var
676   MyObject: IUnknown;
677   MySLink: IShellLink;
678   MyPFile: IPersistFile;
679   WFileName: WideString;
680 begin
681   MyObject := CreateComObject(CLSID_ShellLink);
682   MySLink := MyObject as IShellLink;
683   MyPFile := MyObject as IPersistFile;
684   MySLink.SetPath(PChar(AFileName));
685   MySLink.SetWorkingDirectory(PChar(ExtractFilePath(AFileName)));
686   WFileName := ALocation;
687   MyPFile.Save(PWChar(WFileName), False);
688 end;
689 
690 function GetSpecialFolder(AFolderID: Integer): string;
691 var
692   AInfo: PItemIdList;
693   Buffer: array[0..MAX_PATH] of Char;
694 begin
695   if (SHGetspecialFolderLocation(Application.Handle, AFolderID, aInfo) = NOERROR)
696     and SHGetPathFromIDList(aInfo, Buffer) then
697     Result := StrPas(Buffer);
698 end;
699 
700 procedure MakeShortcut;
701 begin
702   CreateShortcut(Application.ExeName, GetSpecialFolder(CSIDL_COMMON_STARTUP)
703     + '\shortcutname.lnk');
704 end;
705 
706 procedure DeleteShortCut;
707   DeleteFile(PChar(GetSpecialFolder(CSIDL_COMMON_STARTUP) + '\shortcutname.lnk'));
708 end;


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC