Delphi Создание ярлыка на рабочем столе и на панели быстрого запуска

[Sascha]

Достаточно часто в интернете встречается подобный вопрос. И на самом деле это интересная и полезная тема. Данная статья расскажет о том, как создавать свои ярлычки на рабочем столе и на панели быстрого запуска. Сделаем небольшие приготовления:

uses
  {...}, Registry, ShlObj, ComObj, ActiveX;

Из реестра мы будем получать пути к специальным папкам Windows. Остальные библиотеки необходимы для создания ярлыка. Основная процедура по созданию ярлыков выглядит следующим образом:

function TForm1.CreateShortcut(const CmdLine, Args, WorkDir, LinkFile,
  IconFile: string): IPersistFile;
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  WideFile: WideString;
begin
   MyObject := CreateComObject( CLSID_ShellLink );
   MySLink := MyObject as IShellLink;
   MyPFile := MyObject as IPersistFile;
   with MySLink do
   begin
      SetPath( PChar( CmdLine ) );
      SetIconLocation( PChar( IconFile ), 0 );
      SetArguments( PChar( Args ) );
      SetWorkingDirectory( PChar( WorkDir ) );
   end;
   WideFile := LinkFile;
   MyPFile.Save( PWChar( WideFile ), false );
   Result := MyPFile;
end;

// CmdLine - путь к файлу
// Args - параметры командной строки
// WorkDir - директория, в которой находится файл
// LinkFile - путь к папке, в которой будет создан ярлык
// IconFile - путь к файлу-иконке

Для того чтобы узнать путь к специальным папкам Windows, напишем следующую функцию:

function TForm1.GetSystemDir(Key: string): string;
var
  Reg: TRegistry;
begin
   Reg := TRegistry.Create;
   Reg.RootKey := HKEY_CURRENT_USER;
   Reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', false );
   Result := Reg.ReadString( Key ) + '\';
   Reg.CloseKey;
   Reg.Free;
end;

Процедура выбора файла, для которого будет создан ярлык, выглядит следующим образом:

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
   if FileOpenDialog.Execute then
   begin
      Edit1.Text := ExtractFileName( FileOpenDialog.FileName );
      Edit2.Text := FileOpenDialog.FileName;
      Edit3.Text := ExtractFilePath( FileOpenDialog.FileName );
   end;
end;

Если необходимо изменить иконку ярлыка, нужно воспользоваться следующей процедурой:

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
   if IconOpenDialog.Execute then
   begin
      Edit5.Text := IconOpenDialog.FileName;
      Image1.Picture.LoadFromFile( Edit5.Text );
   end;
end;

Если возникнет необходимость отчистить поля формы, а также стереть изображение иконки, следующая процедура поможет в этом.

procedure TForm1.SpeedButton3Click(Sender: TObject);
var
  i: integer;
begin
   for i := 1 to 5 do
      TEdit( FindComponent( 'Edit' + IntToStr( i ) ) ).Text := '';
   Image1.Picture := nil;
end;

И, наконец процедура, которая создаст ярлык на рабочем столе или на панели быстрого запуска, а заодно проверит правильность заполнения полей путем проверки наличия указанного файла в указанном каталоге.

procedure TForm1.SpeedButton4Click(Sender: TObject);
var
  Error: boolean;
  s: string;
begin
   Error := false;
   
   // Проверяем наличие имени ярлыка
   if Edit1.Text = '' then
   begin
      MessageDlg( 'Укажите имя ярлыка.', mtWarning, [mbYes], 0 );
      Error := true;
   end;

   // Если имя ярлыка указано, проверяем существование данного файла
   if not Error then
      if Edit2.Text = '' then
      begin
         MessageDlg( 'Не указан путь к файлу.', mtWarning, [mbYes], 0 );
         Error := true;
      end
      else
         begin
            if not FileExists( Edit2.Text ) then
            begin
               MessageDlg( 'Указанный файл не существует.', mtWarning, [mbYes], 0 );
               Error := true;
            end;
         end;

   // Если указанный файл существует, создаем для него ярлык
   if not Error then
      case RadioGroup1.ItemIndex of
         // Ярлык на рабочем столе
         0: CreateShortcut( Edit2.Text, Edit4.Text, Edit3.Text,
            GetSystemDir( 'Desktop' ) + Edit1.Text + '.lnk', Edit5.Text );
         // Ярлык на панели быстрого запуска
         1: begin
               s := 'Microsoft\Internet Explorer\Quick Launch\';
               CreateShortcut( Edit2.Text, Edit4.Text, Edit3.Text,
               GetSystemDir( 'AppData' ) + s + Edit1.Text + '.lnk', Edit5.Text );
            end;
      end;
end;

Пример: