Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Создание ярлыка для конкретного файла

Автор: VID
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Создание ярлыка для конкретного файла

ВХОДНЫЕ ПАРАМЕТРЫ.
FILENAME - имя файл ДЛЯ КОТОРОГО будет создан ярлык (*.lnk).
DestDirectory - путь к каталогу, в котором должен быть расположен
создаваемый ярлык.
OverwriteExisting - если TRUE, то в случае существования создаваемого ярлыка
в папке назначения, то существующий ярлык с
подобным именем будет переписан.
AddNumberIfExists - если TRUE, то в при существовании ярлыка с подобным
именем в папке назначения,существующий ярлык не будет переписан, а к
создаваемому ярлыку будет добавлено число, определяющее номер копии
создаваемого ярлыка.

ВНИМАНИЕ !!! Параметр OverwriteExisting является более влиятельным по
отношению к параметру AddNumberIfExists, т.е. при передачи
обоим параметрам TRUE, существующий ярлык
(если таковой имеется в папке назначения),
будет переписан.

Зависимости: shlObj, activeX, SysUtils, filectrl, comObj, UBPFD.ExtractFileNameEX
Автор:       VID, snap@iwt.ru, ICQ:132234868, Махачкала
Copyright:   Списал с одного из FAQ + собственные корректировки и расширение возможностей
Дата:        19 апреля 2002 г.
***************************************************** }

function CreateLink(FileName, DestDirectory: string; OverwriteExisting,
  AddNumberIfExists: Boolean): string;

var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  WFileName: WideString;
  X: INTEGER;
begin
  //Изначально RESULT = ''
  Result := '';
  //Если фиайла, для которого создаётся ярлык не существует, или же не
  // существует директории, где должен быть создан ярлык файла, то EXIT
  if (FileExists(FileName) = FALSE) or (DirectoryExists(DestDirectory) = FALSE)
    then
    exit;
  MyObject := CreateComObject(CLSID_SHELLLINK);
  MyPFile := MyObject as IPersistFile;
  MySLink := MyObject as IShellLink;
  with MySLink do
  begin
    SetArguments('');
    SetPath(PChar(FileName));
    SetWorkingDirectory(PChar(ExtractFilePath(FileName)));
  end;

  //Гарантирование проставление завершающего '\' в пути директории
  //расположения создаваемого ярлыка
  if DestDirectory[length(DestDirectory)] <> '\' then
    DestDirectory := DestDirectory + '\';
  // Первичное определене будующего имени ярлыка
  WFileName := DestDirectory + ExtractFileNameEx(FileName, FALSE) + '.lnk';
  //Если ярлык с таким именем уже существует, то
  if (FileExists(WFileName)) then
  begin
    // Если не надо переписывать существующий ярлык, а надо добавить
    // порядковый номер существования к имени создаваемого ярлыка, например
    // blobby1.lnk, blobby2.lnk
    if (OverwriteExisting = FALSE) and (AddNumberIfExists = TRUE) then
    begin
      // Определяем какой именно порядковый номер надо добавить к
      // имени ярлыка
      X := 0;
      repeat
        X := X + 1;
        WFileName := DestDirectory + ExtractFileNameEx(FileName, FALSE)
          + IntToStr(X) + '.lnk';
      until FileExists(WFileName) = FALSE;
      // И сохраняем ярлык
      MyPFile.Save(PWChar(WFileName), FALSE);
      Result := WFileName;
    end;
    //Если надо переписывать существующий ярлык
    if OverwriteExisting = TRUE then
    begin
      //..., то переписываем его :)
      MyPFile.Save(PWChar(WFileName), FALSE);
      Result := WFileName;
    end;
  end
  else
  begin
    //В случае, если ярлыка с подобным имененм ещё нет в папке
    //назначения, то создаём ярлык
    MyPFile.Save(PWChar(WFileName), FALSE);
    Result := WFileName;
  end;
end;
Проект Delphi World © Выпуск 2002 - 2024
Автор проекта: USU Software
Вы можете выкупить этот проект.