Юнит для создания ярлыков без использования модулей ShlObj и ComObj

Delphi , Файловая система , Ярлыки

Автор: KosilkA

unit shortcut;

interface

uses windows;

procedure CreateLink(const FileName, LinkSelfFileName: pchar);
procedure CreateLinkEx(const FileName, RunParams, WorkDir, LinkSelfFileName,
  Description, IconFile: pchar; IconNumber, WndParams: cardinal);

implementation
/////////////////////////////////// cuts from ShlObj
const
  CLSID_ShellLink: TGUID = (
    D1: $00021401; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00,
    $46));
type
{$EXTERNALSYM _SHITEMID}
  _SHITEMID = record
    cb: Word; { Size of the ID (including cb itself) }
    abID: array[0..0] of Byte; { The item ID (variable length) }
  end;
  TSHItemID = _SHITEMID;
{$EXTERNALSYM SHITEMID}
  SHITEMID = _SHITEMID;
  PItemIDList = ^TItemIDList;
{$EXTERNALSYM _ITEMIDLIST}
  _ITEMIDLIST = record
    mkid: TSHItemID;
  end;
  TItemIDList = _ITEMIDLIST;
{$EXTERNALSYM IShellLinkA}
  IShellLinkA = interface(IUnknown) { sl }
    ['{000214EE-0000-0000-C000-000000000046}']
    function GetPath(pszFile: PAnsiChar; cchMaxPath: Integer;
      var pfd: TWin32FindData; fFlags: DWORD): HResult; stdcall;
    function GetIDList(var ppidl: PItemIDList): HResult; stdcall;
    function SetIDList(pidl: PItemIDList): HResult; stdcall;
    function GetDescription(pszName: PAnsiChar; cchMaxName: Integer): HResult;
      stdcall;
    function SetDescription(pszName: PAnsiChar): HResult; stdcall;
    function GetWorkingDirectory(pszDir: PAnsiChar; cchMaxPath: Integer):
      HResult; stdcall;
    function SetWorkingDirectory(pszDir: PAnsiChar): HResult; stdcall;
    function GetArguments(pszArgs: PAnsiChar; cchMaxPath: Integer): HResult;
      stdcall;
    function SetArguments(pszArgs: PAnsiChar): HResult; stdcall;
    function GetHotkey(var pwHotkey: Word): HResult; stdcall;
    function SetHotkey(wHotkey: Word): HResult; stdcall;
    function GetShowCmd(out piShowCmd: Integer): HResult; stdcall;
    function SetShowCmd(iShowCmd: Integer): HResult; stdcall;
    function GetIconLocation(pszIconPath: PAnsiChar; cchIconPath: Integer;
      out piIcon: Integer): HResult; stdcall;
    function SetIconLocation(pszIconPath: PAnsiChar; iIcon: Integer): HResult;
      stdcall;
    function SetRelativePath(pszPathRel: PAnsiChar; dwReserved: DWORD): HResult;
      stdcall;
    function Resolve(Wnd: HWND; fFlags: DWORD): HResult; stdcall;
    function SetPath(pszFile: PAnsiChar): HResult; stdcall;
  end;
{$EXTERNALSYM IShellLink}
  IShellLink = IShellLinkA;
  /////////////////////////////////// End of cuts from ShlObj

  /////////////////////////////////// cuts from ActiveX
type
{$EXTERNALSYM IPersist}
  IPersist = interface(IUnknown)
    ['{0000010C-0000-0000-C000-000000000046}']
    function GetClassID(out classID: TGUID): HResult; stdcall;
  end;
{$EXTERNALSYM IPersistFile}
  IPersistFile = interface(IPersist)
    ['{0000010B-0000-0000-C000-000000000046}']
    function IsDirty: HResult; stdcall;
    function Load(pszFileName: PWideChar; dwMode: Longint): HResult;
      stdcall;
    function Save(pszFileName: PWideChar; fRemember: BOOL): HResult;
      stdcall;
    function SaveCompleted(pszFileName: PWideChar): HResult;
      stdcall;
    function GetCurFile(out pszFileName: PWideChar): HResult;
      stdcall;
  end;

procedure CoUninitialize; stdcall; external 'ole32.dll' name 'CoUninitialize';

function CoInitialize(pvReserved: Pointer): HResult; stdcall; external
  'ole32.dll' name 'CoInitialize';

function CoCreateInstance(const clsid: TGUID; unkOuter: IUnknown;
  dwClsContext: Longint; const iid: TGUID; out pv): HResult; stdcall; external
  'ole32.dll' name 'CoCreateInstance';
////////////////////////////////// End of cuts from ActiveX

procedure CreateLink(const FileName, LinkSelfFileName: pchar);
var
  IObject: IUnknown;
begin
  Coinitialize(nil);
  if CoCreateInstance(CLSID_ShellLink, nil, 1 or
    4, IUnknown, IObject) <> 0 then
  begin
    CoUninitialize;
    exit;
  end;
  (IObject as IShellLink).SetPath(FileName);
  (IObject as IPersistFile).Save(PWChar(WideString(LinkSelfFileName)), FALSE);
  CoUninitialize;
end;

procedure CreateLinkEx(const FileName, RunParams, WorkDir, LinkSelfFileName,
  Description, IconFile: pchar; IconNumber, WndParams: cardinal);
var
  IObject: IUnknown;
begin
  Coinitialize(nil);
  if CoCreateInstance(CLSID_ShellLink, nil, 1 or
    4, IUnknown, IObject) <> 0 then
  begin
    CoUninitialize;
    exit;
  end;
  with (IObject as IShellLink) do
  begin
    SetPath(FileName);
    SetArguments(RunParams);
    SetWorkingDirectory(WorkDir);
    SetDescription(Description);
    SetIconLocation(IconFile, IconNumber);
    SetShowCmd(WndParams);
  end;
  (IObject as IPersistFile).Save(PWChar(WideString(LinkSelfFileName)), FALSE);
  CoUninitialize;
end;

end.

Программный модуль Delphi под именем shortcut предлагает два процедура для создания ярлыков (ссылок или иконок) на операционной системе Windows. Первая процедура, CreateLink, создает простой ярлык с заданным именем файла и именем файла-ссылки. Вторая процедура, CreateLinkEx, позволяет указать болееadvanced опции, такие как параметры запуска, рабочий каталог, описание, файл иконки, номер иконки и параметры окна.

Вот разбивка кода:

1. Первый раздел определяет некоторые константы и типы из Windows API, связанные с shell-ссылками.
2. Второй раздел определяет интерфейс IShellLinkA, который используется объектом shell-ссылки для общения с другими компонентами COM.
3. Третий раздел определяет еще один интерфейс IPersistFile, который обеспечивает методы для сохранения и загрузки файловых данных (т.е., сохранения и загрузки файлов).
4. Четвертый раздел определяет две процедуры: CoUninitialize и CoInitialize. Эти процедуры являются частью кода инициализации COM, который используется для инициализации и очистки компонентов COM.
5. Пятый раздел определяет функцию CoCreateInstance, которая используется для создания экземпляра компонента COM с помощью его класс-идентификатора (clsid).
6. Последние два раздела определяют процедуры CreateLink и CreateLinkEx.

Процедура CreateLink создает простой ярлык с заданным именем файла и именем файла-ссылки, в то время как процедура CreateLinkEx позволяет указать болееadvanced опции, такие как параметры запуска, рабочий каталог, описание, файл иконки, номер иконки и параметры окна. Обе процедуры используют компоненты COM для создания и сохранения ярлыка.

Вот некоторые предложения по улучшению кода:

• Рассмотрите добавление обработки ошибок для вызова функции CoCreateInstance в случае ее неудачи.
• Функции CoInitialize и CoUninitialize должны быть вызваны только раз за программу, поэтому рассмотрите перемещение их в отдельную процедуру инициализации.
• Вместо использования типа PWideChar, можно использовать типы AnsiString или UnicodeString для работы с широкими строками в Delphi.
• Рассмотрите добавление более подробных комментариев и документации, чтобы объяснить цель каждой процедуры и доступные опции.

В целом, этот код предоставляет основное реализацию создания ярлыков на Windows с помощью компонентов COM. Однако он может требовать некоторых изменений для работы правильно в зависимости от вашего конкретного использования.

Юнит для создания ярлыков без использования модулей ShlObj и ComObj в Delphi.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Ярлыки ::