[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