Создание ярлыка.

[wwswowsogon]

Здравствуйте! Не подсажете, как в Lazarus создать ярлык для своей программы?
Пробовал по-дельфийски:

Код: Выделить всё

uses
  ShlObj, ComObj, ActiveX;

procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
var
  IObject: IUnknown;
  SLink: IShellLink;
  PFile: IPersistFile;
begin
  IObject := CreateComObject(CLSID_ShellLink);
  SLink := IObject as IShellLink;
  PFile := IObject as IPersistFile;
  with SLink do
  begin
    SetArguments(PChar(Param));
    SetDescription(PChar(Desc));
    SetPath(PChar(PathObj));
  end;
  PFile.Save(PWChar(WideString(PathLink)), FALSE);
end;

Lazarus не рспознает IUnkown, IShellLink, IPersistFile.

Подскажите, что делать, если не трудно.

[ev]

Подскажите, что делать, если не трудно.

для начала юзать тег [code]

[wwswowsogon]

Э-э-э... Не тут-то было... Спасибо...

[ink]

Это работает.

Код: Выделить всё

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.

Достаточно вызвать CreateLinkEx или CreateLink с необходимыми параметрами.

[wwswowsogon]

Спасибо!

[vitaly_l]

Это работает.

Под Лазарусом 1.9 + fpc 3.1.1 + window-z вышеприведённый код от ink уже не создаёт ярлыки.
Пробовал прописать пути в кодировках системы - всё равно, ярлыки не создаёт .
У кого-нить, есть рабочий код, для создания ярлыков, под Лазарусом 1.9 + fpc 3.1.1, для window-z ?
спасибо.

[Снег Север]

Лазарусом 1.9

Это что-то из далекого светлого будущего?

[Лекс Айрин]

Снег Север, это текущий транк.

[vitaly_l]

Это что-то из далекого светлого будущего?

Транки - на самом деле удобнее, т.к. мгновенно исправляются все баги.
Кстати создание ярлыков, и на 1.62 и 1.64 - тоже работать не должно, т.к. с 3.0 FPC сильно поменялся.
Если у кого есть код создания ярлыков для win, поделитесь прлииииз.

[pupsik]

а это не работает?

[vitaly_l]

а это не работает?

Привет, добрый бородатый Пупсик!
"Это" - тоже не работает.

Но! Если там чуть чуть наколдовать и сделать вот так:

Код: Выделить всё

LinkName := UTF8Decode(InFolder + PathDelim + ShortcutName+'.lnk');  

то благодаря вот этой странной фигне: UTF8Decode <== начинает работать.

[pupsik]

то благодаря вот этой странной фигне: UTF8Decode

значит: работает?

п.с.
Проблема только в "фиговинке"?
Посмотрите что оно "дает" и куда "посылает". Т.е. дебаг в помощь.

[vitaly_l]

значит: работает?

да.

Проблема только в "фиговинке"?

да.

Посмотрите что оно "дает" и куда "посылает". Т.е. дебаг в помощь.

дебаг - это ... о чёрт!
Вы что же, хотите чтобы, я... остановил всю программу и посмотрел, чего пишет эта фигня?
Не... - это жестоко, я не буду останавливать только ради этого всю программу.
Работает с этой фигнёй и ладно... Зачем мне знать, что она там делает?
Важно, что всё стало работать - благодаря этой крохотной фигне!

viewtopic.php?p=27100
viewtopic.php?f=13&t=4326

Кстати в версии 1.64 - эту фигню нужно заменять на UTF8toWinCP,
и вот тут даже взрослые программисты могут заплакать как дети.
потому что переход на версию 3.0 и смена работы с кодировками - обходится очень дорого.

.