//
// Develeped on Lazarus v 4.6 - May 2026
//
unit UDesktopShortcut;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
// User's start and desktop directories for shortcuts.
Windows, windirs, Dos,
// For Latin Characters
lazutf8,
// to create shortcuts
{windows,} shlobj {for special folders}, ActiveX, ComObj,
LazFileUtils
;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
chkShortcutDesktop: TCheckBox;
chkShortcutStartup: TCheckBox;
Label1: TLabel;
lblHasShortcutDesktop: TLabel;
lblHasShortcutStartUp: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
private
procedure GetUserWindowsDirectories();
procedure CreateDesktopShortCut(Target, TargetArguments, ShortcutName: string);
procedure CreateStartupShortCut(Target, TargetArguments, ShortcutName: string);
public
end;
var
Form1: TForm1;
UserDesktop: rawbytestring; // I retrieve the User's Desktop folder.
UserStartUp: rawbytestring; // I retrieve the Windows User's Startup folder
ShortcutInDesktop: string; // shortcut file on the Desktop
ShortcutInStartUp: string; // shortcut file in Windows Startup
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
ShortcutToBeCreated: RawByteString;
begin
// I need to create the shortcut on the desktop.
if (chkShortcutDesktop.Checked = true) And (lblHasShortcutDesktop.Caption = 'lblHasShortcutDesktop=false') then
begin
if fileexists(PChar(ShortcutInDesktop)) then
begin
ShortcutInDesktop := AnsiToUtf8(ShortcutInDesktop);
FileSetAttr(ShortcutInDesktop,0);
end;
// Call the procedure create on the desktop.
// Showmessage ('I'll create the shortcut on the Desktop');
ShortcutToBeCreated:= AnsiToUtf8(Application.ExeName);
CreateDesktopShortCut(Pchar(ShortcutToBeCreated), '', 'DesktopShortcut.lnk');
end;
// I need to delete the shortcut on the desktop, BUT I have to check if it exists and FIRST it's better to filesetatrrib
if (chkShortcutDesktop.Checked = false) And (lblHasShortcutDesktop.Caption = 'lblHasShortcutDesktop=true') then
begin
if fileexists(PChar(ShortcutInDesktop)) then
begin
ShortcutInDesktop := AnsiToUtf8(ShortcutInDesktop);
FileSetAttr(ShortcutInDesktop,0);
DeleteFile(PChar(UTF8ToWinCP(ShortcutInDesktop)))
// The command will only be the one above; the one below is just for testing.
// if DeleteFile(PChar(UTF8ToWinCP(ShortcutInDesktop)))
// then ShowMessage(Pchar(ShortcutInDesktop)+' = deleted')
// else ShowMessage(Pchar(ShortcutInDesktop)+' = did not delete, error = '+
// IntToStr(GetLastError));
end;
end;
// I need to create the shortcut in the Start menu.
if (chkShortcutStartup.Checked = true) And (lblHasShortcutStartUp.Caption = 'lblHasShortcutStartUp=false') then
begin
if fileexists(PChar(ShortcutInStartUp)) then
begin
ShortcutInStartUp := AnsiToUtf8(ShortcutInStartUp);
FileSetAttr(ShortcutInStartUp,0);
end;
// Call the Create shortcut in the Start menu
// Showmessage ('I'll create the shortcut.');
ShortcutToBeCreated:= AnsiToUtf8(Application.ExeName);
CreateStartupShortCut(Pchar(ShortcutToBeCreated), '', 'DesktopShortcut.lnk');
end;
// I need to delete the shortcut on the startmenu, BUT I have to check if it exists and FIRST it's better to filesetatrrib
if (chkShortcutStartup.Checked = false) And (lblHasShortcutStartUp.Caption = 'lblHasShortcutStartUp=true') then
begin
if fileexists(PChar(ShortcutInStartUp)) then
begin
ShortcutInStartUp := AnsiToUtf8(ShortcutInStartUp);
FileSetAttr(ShortcutInStartUp,0);
DeleteFile(PChar(UTF8ToWinCP(ShortcutInStartUp)))
// The command will only be the one above; the one below is just for testing.
// if DeleteFile(PChar(UTF8ToWinCP(ShortcutInStartUp)))
// then ShowMessage(Pchar(ShortcutInStartUp)+' = deleted')
// else ShowMessage(Pchar(ShortcutInStartUp)+' = did not delete, error = '+
// IntToStr(GetLastError));
end;
end;
Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
chkShortcutDesktop.Caption := 'Desktop Shortcut';
chkShortcutStartup.Caption := 'Start Windows Shortcut';
lblHasShortcutDesktop.Caption := 'lblHasShortcutDesktop=false';
lblHasShortcutStartUp.Caption := 'lblHasShortcutStartUp=false';
// lblHasShortcutDesktop.Visible := false;
// lblHasShortcutStartUp.Visible := false;
GetUserWindowsDirectories;
//
Label1.Caption := 'This application works well on Windows 7, 10 and 11.' +#13+#10+
'It also correctly recognizes Latin characters in PlayOnLinux (on Linux Mint).' +#13+#10+ #13+#10+
'To test the Latin Characters: Create a "Windows User" named: Jôsé Márìõñ and runs app in there' +#13+#10+ #13+#10+
'Right-click the Desktop shortcut and you will see that the text boxes: Target and Start in, have been filled in correctly.' +#13+#10+ #13+#10+
'checkbox checked (true) = Create Shortcuts' +#13+#10+
'unchecked = Delete Shortcuts';
// TO SEE THE SHORTCUTS:
// On Windows Execute box type:
// shell:startup or shell:desktop
end;
procedure TForm1.FormShow(Sender: TObject);
begin
// GET THE SHORTCUTS HERE
ShortcutInDesktop := UserDesktop + 'DesktopShortcut.lnk';
ShortcutInDesktop := AnsiToUtf8(ShortcutInDesktop);
// showmessage ('PChar(ShortcutInDesktop) ' + PChar(ShortcutInDesktop));
if fileexists(PChar(ShortcutInDesktop)) then
begin
// showmessage ('There is a shortcut in the Desktop ' + Pchar(ShortcutInDesktop));
chkShortcutDesktop.Checked := True;
lblHasShortcutDesktop.Caption := 'lblHasShortcutDesktop=true';
end;
ShortcutInStartUp := UserStartUp + 'DesktopShortcut.lnk';
ShortcutInStartUp := AnsiToUtf8(ShortcutInStartUp);
// showmessage ('PChar(ShortcutInStartUp) ' + PChar(ShortcutInStartUp));
if fileexists(PChar(ShortcutInStartUp)) then
begin
// showmessage ('There is a shortcut in the start menu.' + Pchar(ShortcutInStartUp));
chkShortcutStartup.Checked := True;
lblHasShortcutStartUp.Caption := 'lblHasShortcutStartUp=true';
end;
end;
// The call is in the Form Create
procedure TForm1.GetUserWindowsDirectories();
begin
UserDesktop := AnsiToUtf8(GetWindowsSpecialDir(CSIDL_DESKTOPDIRECTORY));
if RightStr(UserDesktop, 1) <> '\' then UserDesktop := UserDesktop + '\';
//ShowMessage ('UserDesktop = ' + UserDesktop);
UserStartUp := AnsiToUtf8(GetWindowsSpecialDir(CSIDL_STARTUP));
if RightStr(UserStartUp, 1) <> '\' then UserStartUp := UserStartUp + '\';
//ShowMessage ('Start User ' + UserStartUp + #13 + #13 + 'This is from the Windows 7 Start Menu. = C:\Users\Marck-7\AppData\Roaming\Microsoft\Windows\Start Menu\Programs');
//
// On Windows Execute box type:
// shell:startup or shell:desktop
end;
// from lazarus wiki
procedure TForm1.CreateDesktopShortCut(Target, TargetArguments,
ShortcutName: string);
// usage: CreateShortcut('c:\windows\notepad.exe','c:\MyNotePad.lnk','This is Notepad','');
var
IObject: IUnknown;
ISLink: IShellLink;
IPFile: IPersistFile;
PIDL: PItemIDList;
InFolder: array[0..MAX_PATH] of char;
TargetName: string;
LinkName: widestring;
begin
{ Creates an instance of IShellLink }
IObject := CreateComObject(CLSID_ShellLink);
ISLink := IObject as IShellLink;
IPFile := IObject as IPersistFile;
//
// ***** After MANY attempts, this one WORKED.
// ***** HERE MUST BE ---> UTF8ToWinCP *****
//
ISLink.SetPath(PChar(UTF8ToWinCP(Target)));
ISLink.SetArguments(PChar(UTF8ToWinCP(TargetArguments)));
ISLink.SetWorkingDirectory(PChar(ExtractFilePath(UTF8ToWinCP(Target))));
{ Get the desktop location }
SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
SHGetPathFromIDList(PIDL, InFolder);
// This one worked on shortcut 1.
LinkName := WinCPToUTF8(InFolder) + PathDelim + ShortcutName; // + '.lnk';
// **** Below are just a few tests.
//
// showmessage ('InFolder ' + InFolder);
// showmessage ('InFolder AnsiToUtf8(Pchar( ---- ' + AnsiToUtf8(Pchar(InFolder)));
// showmessage ('WinCPToUTF8(Pchar(InFolder --- ' + WinCPToUTF8(Pchar(InFolder)));
// showmessage ('UTF8toWinCP(Pchar(InFolder --- ' + UTF8toWinCP(Pchar(InFolder)));
//
// showmessage ('PathDelim ' + PathDelim);
// showmessage ('ShortcutName ' + ShortcutName);
// showmessage('1 Pchar(UserDesktop) ----- ' + Pchar(UserDesktop));
// showmessage('2 AnsiToUtf8(Pchar(UserDesktop)) ----- ' + AnsiToUtf8(Pchar(UserDesktop)));
// showmessage('3 UTF8ToWinCP(AnsiToUtf8(Pchar(UserDesktop)) ---------- ' + UTF8ToWinCP(AnsiToUtf8(Pchar(UserDesktop))));
// WinCPToUTF8
//showmessage (PChar(linkName));
{LinkName := InFolder + AnsiToUtf8(PathDelim) + ShortcutName; // + '.lnk';
LinkName := InFolder + UTF8ToWinCP(PathDelim) + ShortcutName; // + '.lnk';
linkName := AnsiToUtf8(linkName);
linkName := UTF8ToWinCP(linkName);
showmessage (PChar(linkName));
Here it only shows C.}
{ Create the link }
IPFile.Save(PWChar(LinkName), False);
end;
procedure TForm1.CreateStartupShortCut(Target, TargetArguments,
ShortcutName: string);
// usage: CreateShortcut('c:\windows\notepad.exe','c:\MyNotePad.lnk','This is Notepad','');
var
IObject: IUnknown;
ISLink: IShellLink;
IPFile: IPersistFile;
PIDL: PItemIDList;
InFolder: array[0..MAX_PATH] of char;
TargetName: string;
LinkName: widestring;
begin
{ Creates an instance of IShellLink }
IObject := CreateComObject(CLSID_ShellLink);
ISLink := IObject as IShellLink;
IPFile := IObject as IPersistFile;
//
// ***** After MANY attempts, this one WORKED.
// ***** HERE MUST BE ---> UTF8ToWinCP *****
//
ISLink.SetPath(PChar(UTF8ToWinCP(Target)));
ISLink.SetArguments(PChar(UTF8ToWinCP(TargetArguments)));
ISLink.SetWorkingDirectory(PChar(ExtractFilePath(UTF8ToWinCP(Target))));
{ Get the desktop location }
SHGetSpecialFolderLocation(0, CSIDL_STARTUP, PIDL);
SHGetPathFromIDList(PIDL, InFolder);
// This one worked on shortcut 1.
LinkName := WinCPToUTF8(InFolder) + PathDelim + ShortcutName; // + '.lnk';
{ Create the link }
IPFile.Save(PWChar(LinkName), False);
end;
end.
Recent
