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
30-Aug-02
Category
System
Language
Delphi 2.x
Views
92
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 uses
111   shellLink;
112 
113 var
114   lnkName: string;
115   FileToInstall: string;
116   LinkFile: string;
117   comment: string;
118   Dest: string; { destination's folder }
119 begin
120   FileToInstall := 'Example.exe';
121   LinkFile := 'Example.lnk';
122   Comment := 'Link to Example.exe';
123   Dest := GetFolderLocation('Desktop')
124     lnkName := CreateLink(FileToInstall, LinkFile, Comment, Dest);
125 end;



Solve 2:

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



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


Solve 4:

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

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



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



Solve 7:

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