Что нового
  • Что бы вступить в ряды "Принятый кодер" Вам нужно:
    Написать 10 полезных сообщений или тем и Получить 10 симпатий.
    Для того кто не хочет терять время,может пожертвовать средства для поддержки сервеса, и вступить в ряды VIP на месяц, дополнительная информация в лс.

  • Пользаватели которые будут спамить, уходят в бан без предупреждения. Спам сообщения определяется администрацией и модератором.

  • Гость, Что бы Вы хотели увидеть на нашем Форуме? Изложить свои идеи и пожелания по улучшению форума Вы можете поделиться с нами здесь. ----> Перейдите сюда
  • Все пользователи не прошедшие проверку электронной почты будут заблокированы. Все вопросы с разблокировкой обращайтесь по адресу электронной почте : info@guardianelinks.com . Не пришло сообщение о проверке или о сбросе также сообщите нам.

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

Sascha

Заместитель Администратора
Команда форума
Администратор
Регистрация
9 Май 2015
Сообщения
1,059
Баллы
155
Возраст
46
Достаточно часто в интернете встречается подобный вопрос. И на самом деле это интересная и полезная тема. Данная статья расскажет о том, как создавать свои ярлычки на рабочем столе и на панели быстрого запуска. Сделаем небольшие приготовления:

Код:
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;
link.gif

Пример:
 

Вложения

  • 3.5 КБ Просмотры: 0
Вверх