nSonic Homepage

 HISTORY:  Original version by
 ========  - Jon E. Scott
      web: http://members.xoom.com/jescott  ("Delphi Code Tips")
      email: jescott@xoommail.com
 

     Some improvements and comments 1999-06-18 by
     Bjorn Mossberg: mossberg@mindspring.com
 

 PURPOSE:  To create a shortcut on the desktop, start menu,
 ========  in a program group, in the SendTo folder,
     or in the SysTray region.

 REQUIRES:
 =========
 uses ShlObj, ComObj, Registry, ActiveX; // and others

 type
  TShortcut = (sc_Desktop, sc_QuickLaunch, sc_SendTo,
      sc_Start, sc_Programs);

 PARAMETERS:
 ===========

 aTarget:  The full path to the executable file
     for which a shortcut is to be created.

 startDir: String specifying the folder that is to be made
     current before aTarget executes. May be blank.

 aCaption: String specifying the "legend" to be written
     under the icon. May be left blank, in which
     case the name of the executable file minus
     its extension is used.
     Caution: Use only legal file characters!

 aGroup:  Meaningful only when aLoc=sc_Programs,
     sc_Desktop, or sc_SendTo.
     Specifies the name of the subfolder to
     which the shortcut is to be added.
     Should already exist.

 aLoc:   One of the values of type ShortcutType:

  }
function CreateAShortcut(aTarget,startDir,aCaption,aGroup: string;
   aLoc: TShortcut; silent: Boolean): Boolean;
var
 anObject: IUnknown;

 function SaveLinkFile(aCap,aFldr: String): Boolean;
 var
  aPFile: IPersistFile;
  s,fName: String;
  wName: WideString;
  i:   Integer;
 begin
  {Save a copy of the object as a link file.
  Try up to 3 times, using tails " (2)" and " (3)".}
  Result := False;
  aPFile := anObject as IPersistFile;
  s   := EmptyStr;
  for i:=1 to 3 do begin
   fName  := aCap + s + ‘.lnk’;
   wName  := MergedPath(aFldr,fName);
   Result := S_OK=aPFile.Save(PWChar(wName), False);
   if Result then Break;
   s := Format(‘ (%d)’,[i]);
  end;
 end;

 function MergedPath(rootDir,subDir: String): String;
 var
  n: Integer;
 begin
  n := Length(rootDir);
  if n=0 then Result := subDir
  else begin
   if rootDir[n]=‘\’ then Delete(rootDir,n,1);
   n := Length(subDir);
   if n=0 then Result := rootDir
   else begin
    if subDir[1]=‘\’ then Delete(subDir,1,1);
    Result := rootDir + ‘\’ + subDir;
   end;
  end;
 end;

const
 BaseKey   = ‘Software\MicroSoft\Windows\CurrentVersion’;
 Shell_Folders = ‘Shell Folders’;
 VDesktop   = ‘Desktop’;
 ProgramMenu  = ‘"Start | Programs" menu’;
var
 aDir,aVar: String;
 aDesc:  String;
 dskTop:  String;
 s,msg:  String;
begin
 Result := False;
 if NOT (CoInitialize(nil) in [S_OK,S_FALSE]) then begin
  ShowMessage(‘Could not initialize OLE COM Library’);
  Exit;
 end;

 {Create an object that can be used as a shortcut
 and later saved as a customized ???.lnk file.}
 anObject := CreateComObject(CLSID_ShellLink);
 try
  with anObject as IShellLink do begin
   {Write in "Target" in the link file:
    The full path of the executable file}
   SetPath(PChar(aTarget));

   {If supplied, write in "Start In" in the link file:
    The folder to be made current before executing "Target".}
   if (Length(startDir)>0) AND DirectoryExists(startDir) then
    SetWorkingDirectory(PChar(startDir));
  end;

  {If aCaption is supplied we use that as the caption
  under the icon representing the shortcut.
  Otherwise we simply strip the extension
  from the name of the target file.
  NOTE: The name of the link file is "aCaption.lnk". }
  if Length(aCaption)=0 then
   aCaption := ExtractFileName(aTarget);
  aCaption := ReplaceAll(aCaption,‘/’,‘-’); {May need other fixing.}
  aCaption := ChangeFileExt(aCaption, EmptyStr);

  aVar := EmptyStr;
  aDesc := EmptyStr;
  case aLoc of
   sc_Start:  aVar := ‘Start Menu’;
   sc_Programs: begin
         aVar := ‘Programs’;
         aDesc := ProgramMenu;
        end;
   sc_SendTo:  begin
         aVar := ‘SendTo’;
         aDesc := aVar + ‘ menu’;
        end;
   sc_QuickLaunch:
    with TRegIniFile.Create(BaseKey+‘\GrpConv’) do try
     aVar := ‘Quick Launch’; {Need aVar for msg later}
     aDir := ReadString(‘MapGroups’,aVar,EmptyStr);
     aDesc := aVar +  ‘ (SysTray) area’;
    finally
     Free;
    end;
  else
   aVar := VDesktop; {Default}
  end;
  if Length(aDesc)=0 then
   aDesc := aVar;

  with TRegIniFile.Create(BaseKey+‘\Explorer’) do try
   {Always get the path to the Desktop as a fallback.}
   dskTop := ReadString(Shell_Folders,VDesktop,EmptyStr);
   if Length(aDir)=0 then begin
    {Here for all cases except _QUICKLAUNCH}
    if Length(aVar)>0 then {Paranoid check}
     aDir := ReadString(Shell_Folders,aVar,EmptyStr);
    if Length(aDir)=0 then {Should never happen, but …}
     aDir := dskTop;
   end;
  finally
   Free;
  end;

  if Length(aDir)=0 then
   {Hard to imagine that we’ll ever be here.}
   ShowMessage(‘Could not determine where to create new shortcut!’)
  else begin
   msg := Format(‘Added shortcut "%s" to the %s’,[aCaption,aDesc]);
   {Subfolders do not make sense for the SysTray or StartMenu.}
   if (Length(aGroup)>0) AND
    (aLoc in [sc_Desktop,sc_SendTo,sc_Programs]) then
   begin
    {The caller is suggesting a subfolder which
    we hope exists. Use it only if it does!}
    s := MergedPath(aDir,aGroup);
    if DirectoryExists(s) then begin
     aDir := s;
     AppendStr(msg,Format(‘ in the subfolder "%s"’,[aGroup]));
    end else
     msg := Format(‘"%s" is not a subfolder of the %s.’
      +‘ Added the shortcut directly instead.’,[aGroup,aDesc]);
   end;

   {Save a copy of the object as a link file.
   Try up to 3 times, using tails " (2)" and " (3)".}
   Result := SaveLinkFile(aCaption,aDir);

   if NOT Result then
    msg := ‘Could not create shortcut to ‘ + aTarget;
   if NOT Result OR NOT silent then
    ShowMessage(msg);

   if (Length(dskTop)>0) AND (aDir<>dskTop) AND
    {Since the dskTop folder is well defined, and not the
    one we just added the shortcut to, we offer to add a
    copy of the shortcut to the Desktop as well.
    We do this whether we failed above or not.}
    (mrYes=MessageDlg(‘Would you like to add a copy’+
      ‘ of the shortcut to the desktop?’,
      mtConfirmation,[mbYes,mbNo],0)) then
   begin
    {Don’t reset Result unless we are successful!}
    msg := ‘esktop shortcut to ‘+aTarget;
    if SaveLinkFile(aCaption,dskTop) then begin
     Result := True;
     msg  := ‘D’+msg+‘ successfully created!’;
    end else
     msg := ‘Could not create d’+msg;
    if NOT Result OR NOT silent then
     ShowMessage(msg);
   end;
  end;
 finally
//  TComObject(anObject).Free; {Cannot do this! Memory leak???}
  CoUninitialize;
 end;
end;