Delphi 11.2 Creating a desktop icon deletes other desktop icons

Question

I'm using the code below, which I culled from here or some other website a long time ago.

The problem is not that the desktop and start menu items are not being created. It is that for some, not all and not in all my testing, other desktop icons are deleted. Is there anything in the code that opens that door, or is this a function of Windows version, user rights etc?

The program is 64-bit Windows only. It runs successfully on Win10/11 in all my testing, including "clean" machines.

Thanks Brian D. Warner

unit uCreateShortcut;

interface

uses
  System.Win.Registry, System.Win.ComObj,
  Winapi.ActiveX, Winapi.ShlObj, Winapi.Windows,
  System.IOUtils, System.SysUtils;

type
  ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER);

function CreateShortcut(SourceFileName: string; // the file the shortcut points to
                        Location: ShortcutType; // shortcut location
                        SubFolder,  // subfolder of location
                        WorkingDir, // working directory property of the shortcut
                        Parameters,
                        Description: string): //  description property of the shortcut
                        string;

function GetProgramDir: string;

implementation

function CreateShortcut(SourceFileName: string; // the file the shortcut points to
                        Location: ShortcutType; // shortcut location
                        SubFolder,  // subfolder of location
                        WorkingDir, // working directory property of the shortcut
                        Parameters,
                        Description: string): //  description property of the shortcut
                        string;
const
  SHELL_FOLDERS_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\Explorer';
  QUICK_LAUNCH_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\GrpConv';
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  Directory, LinkName: string;
  WFileName: WideString;
  Reg: TRegIniFile;
begin
  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;

  MySLink.SetPath(PChar(SourceFileName));
  MySLink.SetArguments(PChar(Parameters));
  MySLink.SetDescription(PChar(Description));

  LinkName := TPath.ChangeExtension(SourceFileName, '.lnk');
  LinkName := ExtractFileName(LinkName);

  // Quicklauch
  if Location = _QUICKLAUNCH then
  begin
    Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
    try
      Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
    finally
      Reg.Free;
    end;
  end
  else
  // Other locations
  begin
    Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
    try
    case Location of
      _OTHERFOLDER : Directory := SubFolder;
      _DESKTOP     : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
      _STARTMENU   : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
      _SENDTO      : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
    end;
    finally
      Reg.Free;
    end;
  end;

  if (Directory <> '') then
  begin
    if (SubFolder <> '') and (Location <> _OTHERFOLDER) then
    begin
      WFileName := Directory + '\' + SubFolder + '\' + LinkName;
    end else
    begin
      WFileName := Directory + '\' + LinkName;
    end;


    if (WorkingDir = '') then
    begin
      MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)));
    end else
    begin
      MySLink.SetWorkingDirectory(PChar(WorkingDir));
    end;

    MyPFile.Save(PWideChar(WFileName), True);
    Result := WFileName;
  end;
end;

{ --------------------------------------------------------- }

function GetProgramDir: string;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    reg.OpenKey(
        'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
    Result := reg.ReadString('Programs');
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;
end.

///////////////////////// Some examples:

procedure TForm1.Button1Click(Sender: TObject);
const
 PROGR = 'c:\temp\Project2.exe';
var
  resPath: string;
begin
  //Create a Shortcut on the Desktop
  CreateShortcut(PROGR, _DESKTOP, '','','','Description');

  //Create a Shortcut in the Startmenu /"Programs"-Folder
  resPath := CreateShortcut(PROGR, _OTHERFOLDER, GetProgramDir,'','','Description');
  if resPath <> '' then
  begin
    ShowMessage('Shortcut Successfully created in: ' + resPath);
  end;
end;

When I ran the program on Win10/11 64-bit machines, no desktop icons were deleted. The same is true for some, but not all users. No icons should be deleted.