DBR Delphi-Ecke

// Siehe auch: Informationen aus Shortcuts lesen

// Getestet mit D4 unter WinME und NT4
// (für höhere Versionen siehe Varante 4)

// Variante 1
// Es wird ein Shortcut (Verknüpfung , Link) zum
// eigenen Programm im Ordner "Programme" erstellt:

uses ShlObj, ComObj, ActiveX, Registry; 
 
function AddToStartMenu(ExeName, ProgrammEintrag, ProgrammName, 
  Beschreibung, Parameter: string): boolean; 
var 
  FObject: IUnknown; 
  FSLink: IShellLink; 
  FPFile: IPersistFile; 
  Folder, Link: string; 
  FileName: WideString; 
  Reg: TRegIniFile; 
begin 
  Reg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer'); 
  try 
    FObject := CreateComObject(CLSID_ShellLink); 
    FSLink := FObject as IShellLink; 
    FPFile := FObject as IPersistFile; 
    with FSLink do begin 
      SetPath(PChar(ExeName)); 
      SetArguments(PChar(Parameter)); 
      SetWorkingDirectory(PChar(ExtractFilePath(ExeName))); 
      SetDescription(PChar(Beschreibung)); 
      SetIconLocation(PChar(ExeName), 0); 
    end; 
    Folder := Reg.ReadString('Shell Folders', 'Programs', '') + '\' + 
      ProgrammEintrag; 
    if CreateDir(Folder) then begin 
      Link := '\' + ProgrammName + '.lnk'; 
      FileName := Folder + Link; 
      FPFile.Save(PWChar(FileName), False); 
      Result := true; 
    end else 
      Result := false; 
  except 
    Result := false; 
  end; 
  Reg.Free; 
end; 
 
// Beispielufruf 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if not AddToStartMenu(application.exename, 'Mein Programm', 'Testprogramm', 
    'Test', '') then showmessage('Fehler'); 
end;

// -------------------------------------------------------------

// Variante 2
// Hier ein umgestricktes Beispiel aus der "Win32 Developer's Referenz"
// zum Erstellen einer Programmgruppe und eines darin befindlichen
// Shortcut (Verknüpfung, Link). Natürlich kann man damit auch in
// bereits bestehende Gruppen (Desktop, Autostart) derartige Links einfügen.

uses Shlobj, ActiveX, ComObj, FileCtrl; 
 
const 
  Lnk: string = ''; 
  Ordner: string = ''; 

  IID_IPersistFile: TGUID = 
  (D1: $0000010B; D2: $0000; D3: $0000; 
    D4: ($C0, $00, $00, $00, $00, $00, $00, $46)); 
    // stammt aus OLE2.PAS
 
function SpezialOrdner(welcher: integer): string; 
var 
  pidl: PItemIDList; 
  Pfad: PChar; 
  Malloc: IMalloc;
begin 
  result := ''; 
  SHGetMalloc(Malloc); 
  if Malloc = nil then exit; 
  if SHGetSpecialFolderLocation(0, welcher, pidl) = NOERROR 
    then begin 
    Pfad := StrAlloc(max_path); 
    if SHGetPathFromIDList(pidl, Pfad) then begin 
      result := Pfad; 
      if ansilastchar(result) <> '\' then result := result + '\'; 
    end; 
    StrDispose(Pfad); 
    Malloc.Free(pidl); 
  end; 
end;
 
function makeLink(was, wohin: string): boolean; 
var 
  isl: IShellLink; 
  ipf: IPersistFile; 
begin 
  result := false; 
  if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, 
    IID_IShellLinkA, isl)) 
    then begin 
    isl.SetPath(PChar(was)); 
    if SUCCEEDED(isl.QueryInterface(IID_IPersistFile, ipf)) then 
      result := ipf.Save(StringToOLEStr(wohin), true) = S_OK; 
  end; 
end; 
 
 
// Beispielufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
// zunächst das Erstellen der Gruppe "MyNewGroup" 
// (als Beispiel im Ordner "Startmenü/Programme"), 
  Ordner := SpezialOrdner(CSIDL_Programs); 
  if Ordner <> '' then begin 
    Ordner := Ordner + 'MyNewGroup'; 
    if (not CreateDirectory(PChar(Ordner), nil)) 
      and (getlasterror <> ERROR_ALREADY_EXISTS) 
      then showmessage('Erstellen der Programmgruppe fehlgeschlagen') 
    else begin 
// dann die lnk-Datei erzeugen 
      Lnk := 'EuroStck.lnk'; 
      if ansilastchar(Ordner) <> '\' then Ordner := Ordner + '\'; 
      if not makeLink('D:\Programme\EuroStck.exe', Ordner + Lnk) 
        then showmessage('Shortcut wurde nicht erstellt'); 
    end; 
  end else showmessage('Spezial-Ordner nicht aufgefunden'); 
end; 
 
 
// Beides wieder löschen 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  if FileExists(Ordner + Lnk) then 
    if not deletefile(PChar(Ordner + Lnk)) then 
      showmessage('Shortcut konnte nicht gelöscht werden'); 
  if DirectoryExists(Ordner) then 
    if not RemoveDirectory(PChar(Ordner)) 
      then showmessage('Löschen der Programmgruppe fehlgeschlagen'); 
end;

// "Spezial-Ordner"
// Startmenü          : CSIDL_STARTMENU
// Startmenü/Programme: CSIDL_PROGRAMS
// Autostart          : CSIDL_STARTUP
// Desktop            : CSIDL_DESKTOPDIRECTORY
// Senden an          : CSIDL_SENDTO
// Eigene Dateien     : CSIDL_PERSONAL
// Shriften           : CSIDL_FONTS

// -------------------------------------------------------------

// Variante 3 (allgemeine Variante von 1)
// Hier noch eine andere Möglichkeit eine Verknüpfung zu erstellen, welche
// ohne IID_IPersistFile funktioniert. Es können auch Programm-Parameter
// und eine Icon-Quelle angegeben werden. Im Beispiel wird der Link im Ordner
// "C:\" erstellt; man kann natürlich stattdessen wieder Special-Folder
// einsetzen, z.B.: "SpezialOrdner(CSIDL_DESKTOPDIRECTORY)"
// (dazu benötigt man auch die Funktion aus Variante 2).

uses ShlObj, ActiveX, ComObj; 
 
procedure MakeLink(Was, Parameter, Wohin, 
  IconQuelle: string; IconStelle: integer); 
var 
  IUK: IUnknown; 
  ISL: IShellLink; 
  IPF: IPersistFile; 
begin 
  IUK := CreateComObject(CLSID_ShellLink); 
  ISL := IUK as IShellLink; 
  IPF := IUK as IPersistFile; 
  ISL.SetPath(PChar(Was)); 
  if Parameter <> '' then 
    ISL.SetArguments(pchar(Parameter)); 
  ISL.SetWorkingDirectory(pChar(ExtractFilePath(Was))); 
  if AnsiLastChar(Wohin) <> '\' then Wohin := Wohin + '\'; 
  if IconQuelle <> '' then 
    ISL.SetIconLocation(pchar(IconQuelle), IconStelle); 
  IPF.Save(StringToOLEStr(Wohin + 
    ChangeFileExt(ExtractFilename(Was), '.lnk')), false); 
end; 
 
 
// Verknüpfung mit einem Parameter und dem ursprünglichen Icon 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  MakeLink('D:\Programme\EuroStck.exe', 'MyParameter', 'C:\', '', 0); 
end; 
 
// Verknüpfung ohne Parameter, aber mit anderem Icon 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  MakeLink('D:\Programme\EuroStck.exe', '', 'C:\', 
    'Shell32.dll', 51); 
end;

//-------------------------------------------------------------



// Variante 4
// Getestet unter W11 mit Delphi 10.4

uses Winapi.ShlObj, Winapi.ActiveX; 
 
function CreateLink(aFileName, aWorkingdir, aLinkFileName, aParameter, 
  aLinkDestination, aIconsource: String; aIconplace: integer): Boolean; 
var 
  ISL: IShellLink; 
  IPF: IPersistFile; 
begin 
  Result := False; 
  aLinkDestination := IncludeTrailingPathDelimiter(aLinkDestination); 
  if not FileExists(aFileName) then 
    exit; 
  if not DirectoryExists(aLinkDestination) then 
    exit; 
  if SUCCEEDED(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_inPROC_SERVER, 
    IID_IShellLinkW, ISL)) then 
  begin 
    ISL.SetPath(PWideChar(aFileName)); 
    ISL.SetArguments(PWideChar(aParameter)); 
    ISL.SetWorkingDirectory(PWideChar(aWorkingdir)); 
    ISL.SetIconLocation(PWideChar(aIconsource), aIconplace); 
    if SUCCEEDED(ISL.QueryInterface(IPersistFile, IPF)) then 
    begin 
      IPF.Save(PWideChar(aLinkDestination + aLinkFileName + '.lnk'), True); 
      Result := True; 
    end; 
  end; 
end; 
 
// Beispielaufruf (Link auf Desktop) 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  pdl: PItemIDList; 
  P: Pchar; 
  s, quelle: string; 
  stelle: integer; 
begin 
  GetMem(P, max_path); 
  SHGetSpecialFolderLocation(Application.Handle, CSIDL_DESKTOPDIRECTORY, pdl); 
  SHGetPathFromIDList(pdl, P); 
  s := P; 
  FreeMem(P); 
  quelle := 'Shell32.dll'; // 'D:\WinSpy.exe'; 
  stelle := 23; // 0; 
  if not CreateLink('D:\WinSpy.exe', 'D:\', 'TestName', 'MyParameter', s, 
    quelle, stelle) then 
    ShowMessage('FEHLER'); 
end;