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



Автор: 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, [email protected], 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;

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