Текущий архив: 2009.03.29;
Скачать: CL | DM;

Вниз

Ярлыки в Delphi   Найти похожие ветки 

← →
Timoha ©   (2008-04-12 12:27) [0]

Люди, подскажите, пожалуйста, как программно создавать ярлык с назначенным быстрым сочетанием клавиш?

---

← →
{RASkov} ©   (2008-04-12 13:12) [1]

> [0] Timoha ©   (12.04.08 12:27)

unit shortcut;
interface
uses windows;
{ WndParams
SW_SHOWNORMAL соответствует варианту Normal window
SW_SHOWMINNOACTIVE соответствует варианту Minimized
SW_SHOWMAXIMIZED соответствует варианту Maximized}

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. © откуда-то "сперто")
Смотри метод SetHotkey.
Как вариант найди компонент TVirtualShellLink от Mustangpeak...

---

Страницы: 1 вся ветка

Текущий архив: 2009.03.29;
Скачать: CL | DM;

Наверх

Память: 0.48 MB
Время: 0.028 c