[fpc-pascal]Links in Windows
Gabor DEAK JAHN
djg at tramontana.co.hu
Thu Oct 18 20:18:08 CEST 2001
At 10/18/01 10:09 AM, you wrote:
Pavel,
> I'm interested in how to create the shortcut, can you please post your
> source here?
It's free for any use, of course, could be added to the contributed units as
well. Do I have to add it myself or the FPC site admin will do that?
-------------- next part --------------
{ A simple demo for the Shell helper unit. }
{ (C) Copyright 2001, Tramontana Co. Released into the public domain. }
{$APPTYPE CONSOLE}
program ShortCut;
uses
Windows, Strings, Shell;
var
Path : PChar;
begin
Path := StrAlloc (MAX_PATH);
GetDesktopFolder (true, Path);
StrCat (Path, '\Test.lnk');
CreateShortcut (Path, 'C:\Test.exe', nil, 'A test entry', 'C:\Text.exe', 0);
StrDispose (Path);
end.
-------------- next part --------------
{ Shell helper routines to create Start Menu and Desktop shortcuts. }
{ (C) Copyright 2001, Tramontana Co. Released into the public domain. }
unit Shell;
interface
uses
Windows;
const
{ GetCurrentPlatform constants }
pfAll = %11111111;
pfWin31 = %00000001;
pfWin95 = %00000010;
pfWin98 = %00000100;
pfWinME = %00001000;
pfWin9x = pfWin95 or pfWin98 or pfWinME;
pfWinNT3 = %00010000;
pfWinNT4 = %00100000;
pfWin2000 = %01000000;
pfWinNTx = pfWinNT3 or pfWinNT4 or pfWin2000;
pfWin16 = pfWin31;
pfWin32 = pfWin9x or pfWinNTx;
{ Execution context constants }
CLSCTX_INPROC_SERVER = 1;
CLSCTX_INPROC_HANDLER = 2;
CLSCTX_LOCAL_SERVER = 4;
CLSCTX_INPROC_SERVER16 = 8;
CLSCTX_REMOTE_SERVER = 16;
CLSCTX_SERVER = CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER;
CLSCTX_ALL = CLSCTX_INPROC_HANDLER or CLSCTX_SERVER;
{ SHGetSpecialFolder... constants }
CSIDL_PROGRAMS = $0002;
CSIDL_DESKTOPDIRECTORY = $0010;
CSIDL_COMMON_PROGRAMS = $0017;
CSIDL_COMMON_DESKTOPDIRECTORY = $0019;
{ Various GUIDs/CLSIDs }
CLSID_ShellDesktop : GUID = (Data1 : $00021400; Data2 : 0; Data3 : 0; Data4 : ($C0, 0, 0, 0, 0, 0, 0, $46));
CLSID_ShellLink : GUID = (Data1 : $00021401; Data2 : 0; Data3 : 0; Data4 : ($C0, 0, 0, 0, 0, 0, 0, $46));
IID_IShellLink : GUID = (Data1 : $000214EE; Data2 : 0; Data3 : 0; Data4 : ($C0, 0, 0, 0, 0, 0, 0, $46));
IID_IPersistFile : GUID = (Data1 : $0000010B; Data2 : 0; Data3 : 0; Data4 : ($C0, 0, 0, 0, 0, 0, 0, $46));
type
{$PACKRECORDS 1}
{ COM interfaces -- without explicit compiler support, also runs with FPC 1.0x }
{ Note that the original Ole2.pp coming with the compiler is not working, this is how IUnknown should look like: }
{ IUnknown }
PIUnknown = ^IUnknown;
IUnknown = packed record
vtbl : ^IUnknownVtbl;
end;
IUnknownVtbl = packed record
QueryInterface : function (const this : PIUnknown; const iid: TIID; var obj): HResult; stdcall;
AddRef : function (const this : PIUnknown) : longint; stdcall;
Release : function (const this : PIUnknown) : longint; stdcall;
end;
{ IMalloc }
PPIMalloc = ^PIMalloc;
PIMalloc = ^IMalloc;
IMalloc = packed record
vtbl : ^IMallocVtbl;
end;
IMallocVtbl = packed record
QueryInterface : function (const this : PIMalloc; const iid: TIID; var obj): HResult; stdcall;
AddRef : function (const this : PIMalloc) : ULONG; stdcall;
Release : function (const this : PIMalloc) : ULONG; stdcall;
Alloc : function (const this : PIMalloc; cb : ULONG) : pointer; stdcall;
Realloc : function (const this : PIMalloc; var pv; cb : ULONG) : pointer; stdcall;
Free : procedure (const this : PIMalloc; var pv); stdcall;
GetSize : function (const this : PIMalloc; var pv) : ULONG; stdcall;
DidAlloc : function (const this : PIMalloc; var pv) : INT; stdcall;
HeapMinimize : procedure (const this : PIMalloc); stdcall;
end;
{ IShellLink }
PIShellLink = ^IShellLink;
IShellLink = packed record
vtbl : ^IShellLinkVtbl;
end;
IShellLinkVtbl = packed record
QueryInterface : function (const this : PIShellLink; const iid: TIID; var obj): HResult; stdcall;
AddRef : function (const this : PIShellLink) : ULONG; stdcall;
Release : function (const this : PIShellLink) : ULONG; stdcall;
GetPath : function (const this : PIShellLink; pszFile : LPSTR; cchMaxPAth : INT; var fd : WIN32_FIND_DATA; Flags : DWORD) : hResult; stdcall;
GetIDList : function (const this : PIShellLink; var pidl : LPITEMIDLIST) : hResult; stdcall;
SetIDList : function (const this : PIShellLink; pidl : LPITEMIDLIST) : hResult; stdcall;
GetDescription : function (const this : PIShellLink; pszName : LPSTR; cchMaxName : INT) : hResult; stdcall;
SetDescription : function (const this : PIShellLink; pszName : LPSTR) : hResult; stdcall;
GetWorkingDirectory : function (const this : PIShellLink; pszDir : LPSTR; cchMaxName : INT) : hResult; stdcall;
SetWorkingDirectory : function (const this : PIShellLink; pszDir : LPSTR) : hResult; stdcall;
GetArguments : function (const this : PIShellLink; pszArgs : LPSTR; cchMaxName : INT) : hResult; stdcall;
SetArguments : function (const this : PIShellLink; pszArgs : LPSTR) : hResult; stdcall;
GetHotkey : function (const this : PIShellLink; var wHotKey : WORD) : hResult; stdcall;
SetHotkey : function (const this : PIShellLink; wHotKey : WORD) : hResult; stdcall;
GetShowCmd : function (const this : PIShellLink; var iShowCmd : INT) : hResult; stdcall;
SetShowCmd : function (const this : PIShellLink; iShowCmd : INT) : hResult; stdcall;
GetIconLocation : function (const this : PIShellLink; pszIconPath : LPSTR; cchIconPath : INT; var iIcon : INT) : hResult; stdcall;
SetIconLocation : function (const this : PIShellLink; pszIconPath : LPSTR; iIcon : INT) : hResult; stdcall;
SetRelativePath : function (const this : PIShellLink; pszPathRel : LPSTR; wReserved : DWORD) : hResult; stdcall;
Resolve : function (const this : PIShellLink; hwnd : HWND; fFlags : DWORD) : hResult; stdcall;
SetPath : function (const this : PIShellLink; pszFile : LPSTR) : hResult; stdcall;
end;
{ IPersistFile }
PIPersistFile = ^IPersistFile;
IPersistFile = packed record
vtbl : ^IPersistFileVtbl;
end;
IPersistFileVtbl = packed record
QueryInterface : function (const this : PIPersistFile; const iid: TIID; var obj): HResult; stdcall;
AddRef : function (const this : PIPersistFile) : ULONG; stdcall;
Release : function (const this : PIPersistFile) : ULONG; stdcall;
GetClassID : function (const this : PIPersistFile; ClassID : TCLSID) : hResult; stdcall;
IsDirty : function (const this : PIPersistFile) : hResult; stdcall;
Load : function (const this : PIPersistFile; plszFilename : LPWSTR; dwMode : DWORD) : hResult; stdcall;
Save : function (const this : PIPersistFile; plszFilename : LPWSTR; fRemember : BOOL) : hResult; stdcall;
SaveCompleted : function (const this : PIPersistFile; plszFilename : LPWSTR) : hResult; stdcall;
GetCurFile : function (const this : PIPersistFile; var plszFilename : LPWSTR) : hResult; stdcall;
end;
{ GetCurrentPlatform -- determines the version of Windows
RETURNS
a pfXXXX constant }
function GetCurrentPlatform : cardinal;
{ CreateShortcut -- creates a shortcut (.lnk) file with the specified parameters
INPUT
pszLinkFile = path of the shortcut (.lnk) file
pszPathName = the path of the file the shortcut references to
pszArgs = optional arguments for the referenced file
pszDesc = shortcut description (menu entry in Start Menu)
pszIconPath = path to a file containing an icon resource (.EXE, .DLL, .RES, .ICO)
nIconIndex = zero based index number of the icon in the pszIconPath file
RETURNS
S_OK = shortcut succesfully created
E_FAIL or anything else = creation failed }
function CreateShortcut (pszLinkFile, pszPathName, pszArgs, pszDesc, pszIconPath : LPSTR; nIconIndex : INT) : hResult;
{ GetDesktopFolder -- returns the folder of the Desktop
INPUT
ForThisUser = on multi-user systems (NT/2000): TRUE queries the desktop of the current user, FALSE that of all users;
on other systems (95/98/ME): its value is not important
OUTPUT
szPath = the string the folder name will be assigned to, must be at least MAX_PATH long }
procedure GetDesktopFolder (ForThisUser : Boolean; szPath : LPSTR);
{ GetStartMenuFolder -- returns the folder of the Start Menu
INPUT
ForThisUser = on multi-user systems (NT/2000): TRUE queries the Start Menu of the current user, FALSE that of all users;
on other systems (95/98/ME): its value is not important
OUTPUT
szPath = the string the folder name will be assigned to, must be at least MAX_PATH long }
procedure GetStartMenuFolder (ForThisUser : Boolean; szPath : LPSTR);
function SHGetMalloc (ppMalloc : PPIMalloc) : hResult; external 'SHELL32' name 'SHGetMalloc';
function CoCreateInstance (rclsid : TCLSID; pUnkOuter : PIUnknown; dwClsContext : longint; riid : TIID; var ppv) : hResult; external 'OLE32' name 'CoCreateInstance';
function CoInitialize (pvReserved : pointer) : hResult; external 'OLE32' name 'CoInitialize';
procedure CoUninitialize; external 'OLE32' name 'CoUninitialize';
implementation
var
CurrentPlatform : cardinal;
function GetCurrentPlatform : cardinal;
var
VersionInfo : OSVERSIONINFO;
begin
VersionInfo.dwOSVersionInfoSize := sizeof (OSVERSIONINFO);
GetVersionEx (VersionInfo);
case VersionInfo.dwPlatformId of
VER_PLATFORM_WIN32s:
GetCurrentPlatform := pfWin31;
VER_PLATFORM_WIN32_WINDOWS:
case VersionInfo.dwMinorVersion of
0: GetCurrentPlatform := pfWin95;
1: GetCurrentPlatform := pfWin98;
else GetCurrentPlatform := pfWinME;
end;
VER_PLATFORM_WIN32_NT:
case VersionInfo.dwMajorVersion of
3: GetCurrentPlatform := pfWinNT3;
4: GetCurrentPlatform := pfWinNT4;
5: GetCurrentPlatform := pfWin2000;
end;
else GetCurrentPlatform := 0;
end;
end; { GetCurrentPlatform }
function CreateShortcut (pszLinkFile, pszPathName, pszArgs, pszDesc, pszIconPath : LPSTR; nIconIndex : INT) : hResult;
var
hres : hResult;
link : PIShellLink;
f : PIPersistFile;
lszPath : array [0..MAX_PATH] of WCHAR;
begin
hres := E_FAIL;
CoInitialize (nil);
if CoCreateInstance (CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLink, link) = S_OK then
begin
link^.vtbl^.SetPath (link, pszPathName);
if pszArgs <> nil then link^.vtbl^.SetArguments (link, pszArgs);
link^.vtbl^.SetDescription (link, pszDesc);
link^.vtbl^.SetIconLocation (link, pszIconPath, nIconIndex);
if link^.vtbl^.QueryInterface (link, IID_IPersistFile, f) = S_OK then
begin
MultiByteToWideChar (CP_ACP, 0, pszLinkFile, -1, lszPath, MAX_PATH);
hres := f^.vtbl^.Save (f, lszPath, true);
f^.vtbl^.Release (f);
end;
link^.vtbl^.Release (link);
end;
CoUninitialize;
CreateShortcut := hres;
end; { CreateShortcut }
(* The reason for using SHGetSpecialFolderLocation instead of SHGetSpecialFolderPath is that the second is only
available from the version 4.71 (Internet Explorer 4) of the Shell32.dll while the first is present on all systems
starting with NT 4 and Win 95. *)
procedure GetDesktopFolder (ForThisUser : Boolean; szPath : LPSTR);
var
Memory : PIMalloc;
pidl : LPITEMIDLIST;
begin
Memory := nil;
pidl := nil;
if SHGetMalloc (@Memory) = NOERROR then
begin
if not ForThisUser and ((CurrentPlatform and pfWinNTx) > 0) then
SHGetSpecialFolderLocation (0, CSIDL_COMMON_DESKTOPDIRECTORY, pidl)
else
SHGetSpecialFolderLocation (0, CSIDL_DESKTOPDIRECTORY, pidl);
SHGetPathFromIDList (pidl, szPath);
end;
if (pidl <> nil) and (Memory <> nil) then Memory^.vtbl^.Free (Memory, pidl);
if (Memory <> nil) then Memory^.vtbl^.Release (Memory);
end; { GetDesktopFolder }
procedure GetStartMenuFolder (ForThisUser : Boolean; szPath : LPSTR);
var
Memory : PIMalloc;
pidl : LPITEMIDLIST;
begin
Memory := nil;
pidl := nil;
if SHGetMalloc (@Memory) = NOERROR then
begin
if not ForThisUser and ((CurrentPlatform and pfWinNTx) > 0) then
SHGetSpecialFolderLocation (0, CSIDL_COMMON_PROGRAMS, pidl)
else
SHGetSpecialFolderLocation (0, CSIDL_PROGRAMS, pidl);
SHGetPathFromIDList (pidl, szPath);
end;
if (pidl <> nil) and (Memory <> nil) then Memory^.vtbl^.Free (Memory, pidl);
if (Memory <> nil) then Memory^.vtbl^.Release (Memory);
end; { GetStartMenuFolder }
begin
CurrentPlatform := GetCurrentPlatform;
end.
-------------- next part --------------
Regards,
Gabor DEAK JAHN
-------------------------------------------------------------------
Gabor DEAK JAHN -- Budapest, Hungary.
WWW: www.tramontana.co.hu
E-mail: djg at tramontana.co.hu
More information about the fpc-pascal
mailing list