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

Автор: 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 World © Выпуск 2002 - 2004
Автор проекта: ___Nikolay