Создание ярлыка для конкретного файла

Советы » Ярлыки » Создание ярлыка для конкретного файла

{ **** 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

;

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com