{ **** 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 := "";
//Если фиайла, для которого создаётся ярлык не существует, или же не// существует директории, где должен быть создан ярлык файла, то EXITif (FileExists(FileName) = FALSE) or (DirectoryExists(DestDirectory) = FALSE)
then
exit;
MyObject := CreateComObject(CLSID_SHELLLINK);
MyPFile := MyObject as IPersistFile;
MySLink := MyObject as IShellLink;
with MySLink dobegin
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)) thenbegin// Если не надо переписывать существующий ярлык, а надо добавить// порядковый номер существования к имени создаваемого ярлыка, например// blobby1.lnk, blobby2.lnkif (OverwriteExisting = FALSE) and (AddNumberIfExists = TRUE) thenbegin// Определяем какой именно порядковый номер надо добавить к// имени ярлыка
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 thenbegin//..., то переписываем его :)
MyPFile.Save(PWChar(WFileName), FALSE);
Result := WFileName;
end;
endelsebegin//В случае, если ярлыка с подобным имененм ещё нет в папке//назначения, то создаём ярлык
MyPFile.Save(PWChar(WFileName), FALSE);
Result := WFileName;
end;
end;
Если Вас заинтересовала или понравилась информация по разработке на Delph - "Создание ярлыка для конкретного файла", Вы можете поставить закладку в социальной сети или в своём блоге на данную страницу: Так же Вы можете задать вопрос по работе этого модуля или примера через форму обратной связи, в сообщение обязательно указывайте название или ссылку на статью!