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

Вопросы программирования и использования среды Lazarus.

Модератор: Модераторы

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

Сообщение wwswowsogon » 23.12.2008 21:44:05

Здравствуйте! Не подсажете, как в 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.

Подскажите, что делать, если не трудно.
wwswowsogon
новенький
 
Сообщения: 46
Зарегистрирован: 23.12.2008 20:41:37

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

Сообщение ev » 23.12.2008 21:51:12

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

для начала юзать тег [code] ;)
ev
долгожитель
 
Сообщения: 1685
Зарегистрирован: 27.04.2005 23:19:06
Откуда: Москва

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

Сообщение wwswowsogon » 23.12.2008 22:16:18

Э-э-э... Не тут-то было... Спасибо... :(
wwswowsogon
новенький
 
Сообщения: 46
Зарегистрирован: 23.12.2008 20:41:37

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

Сообщение ink » 26.12.2008 09:26:44

Это работает.
Код: Выделить всё
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 с необходимыми параметрами.
ink
незнакомец
 
Сообщения: 3
Зарегистрирован: 25.12.2008 12:00:53

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

Сообщение wwswowsogon » 13.03.2009 22:12:37

Спасибо! :wink:
wwswowsogon
новенький
 
Сообщения: 46
Зарегистрирован: 23.12.2008 20:41:37

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

Сообщение vitaly_l » 19.04.2017 11:26:13

ink писал(а):Это работает.

Под Лазарусом 1.9 + fpc 3.1.1 + window-z вышеприведённый код от ink уже не создаёт ярлыки.
Пробовал прописать пути в кодировках системы - всё равно, ярлыки не создаёт :cry: :cry: :cry: .
:roll: У кого-нить, есть рабочий код, для создания ярлыков, под Лазарусом 1.9 + fpc 3.1.1, для window-z ?
спасибо.
Аватара пользователя
vitaly_l
долгожитель
 
Сообщения: 2855
Зарегистрирован: 31.01.2012 16:41:41

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

Сообщение Снег Север » 19.04.2017 12:36:45

vitaly_l писал(а):Лазарусом 1.9
Это что-то из далекого светлого будущего? :D
Аватара пользователя
Снег Север
энтузиаст
 
Сообщения: 930
Зарегистрирован: 27.11.2007 16:14:47

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

Сообщение Лекс Айрин » 19.04.2017 12:40:40

Снег Север, это текущий транк.
Аватара пользователя
Лекс Айрин
долгожитель
 
Сообщения: 3817
Зарегистрирован: 19.02.2013 16:54:51

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

Сообщение vitaly_l » 19.04.2017 13:13:42

Снег Север писал(а):Это что-то из далекого светлого будущего?

Транки - на самом деле удобнее, т.к. мгновенно исправляются все баги.
Кстати создание ярлыков, и на 1.62 и 1.64 - тоже работать не должно, т.к. с 3.0 FPC сильно поменялся.
Если у кого есть код создания ярлыков для win, :roll: поделитесь прлииииз.
Аватара пользователя
vitaly_l
долгожитель
 
Сообщения: 2855
Зарегистрирован: 31.01.2012 16:41:41

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

Сообщение pupsik » 20.04.2017 19:27:14

а это не работает?
pupsik
энтузиаст
 
Сообщения: 961
Зарегистрирован: 20.08.2014 16:20:13

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

Сообщение vitaly_l » 20.04.2017 19:38:05

pupsik писал(а):а это не работает?

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

Но! Если там чуть чуть наколдовать и сделать вот так:
Код: Выделить всё
LinkName := UTF8Decode(InFolder + PathDelim + ShortcutName+'.lnk'); 

то благодаря вот этой странной фигне: UTF8Decode <== начинает работать.
Аватара пользователя
vitaly_l
долгожитель
 
Сообщения: 2855
Зарегистрирован: 31.01.2012 16:41:41

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

Сообщение pupsik » 20.04.2017 19:55:35

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

п.с.
Проблема только в "фиговинке"? :lol:
Посмотрите что оно "дает" и куда "посылает". Т.е. дебаг в помощь.
pupsik
энтузиаст
 
Сообщения: 961
Зарегистрирован: 20.08.2014 16:20:13

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

Сообщение vitaly_l » 20.04.2017 20:04:16

pupsik писал(а):значит: работает?

да.
pupsik писал(а):Проблема только в "фиговинке"?

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

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

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

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

.
Аватара пользователя
vitaly_l
долгожитель
 
Сообщения: 2855
Зарегистрирован: 31.01.2012 16:41:41


Вернуться в Lazarus

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 7

Рейтинг@Mail.ru