freepascal.compiler/installer/winshell.pas

{ Shell helper routines to create Start Menu and Desktop shortcuts. }
{ (C) Copyright 2001, Tramontana Co. Released into the public domain. }
{ 2003.01.27: renamed WinShell to remember that it is windows specific by Pierre Muller }
{ 2003.01.28: IShellLinkDataList support added by Pierre Muller }

unit WinShell;

interface

uses
  Windows;
type
  INT = WINT;
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_IShellLinkDataList : GUID = (Data1 : $45E2B4AE; Data2 : $B1C3; Data3 : $11D0;
    Data4 : ($B9, $2f, 0, $A0, $C9, $03, $12, $E1));
  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; pv : pointer); stdcall;
    GetSize : function (const this : PIMalloc; pv : pointer) : ULONG; stdcall;
    DidAlloc : function (const this : PIMalloc; pv : pointer) : 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;


{    IShellLinkDataList }
{ inplemented in shell32.dll version 4.71 or later }

{Data block structureDescription}
const
  EXP_DARWIN_ID_SIG        = $A0000006;   // The link's Microsoft© Windows© Installer identifier (ID).
  EXP_LOGO3_ID_SIG         = $A0000007;
  EXP_SPECIAL_FOLDER_SIG   = $A0000005;   // Special folder information.
  EXP_SZ_LINK_SIG          = $A0000001;   // The target name.
  EXP_SZ_ICON_SIG          = $A0000007;   // The icon name.
  NT_CONSOLE_PROPS_SIG     = $A0000002;   // Console properties.
  NT_FE_CONSOLE_PROPS_SIG  = $A0000004;   // The console's code page.

  SLDF_HAS_ID_LIST         = $00000001;   // The link has ID list.
  SLDF_HAS_LINK_INFO       = $00000002;   // The link has LinkInfo.
  SLDF_HAS_NAME            = $00000004;   // The link has a name.
  SLDF_HAS_RELPATH         = $00000008;   // The link has a relative path.
  SLDF_HAS_WORKINGDIR      = $00000010;   // The link has a working directory.
  SLDF_HAS_ARGS            = $00000020;   // The link has arguments.
  SLDF_HAS_ICONLOCATION    = $00000040;   // The link has an icon location.
  SLDF_UNICODE             = $00000080;   // The strings are unicode.
  SLDF_FORCE_NO_LINKINFO   = $00000100;   // Do not create link information. Distributed tracking will be disabled.
  SLDF_HAS_EXP_SZ          = $00000200;   // The link contains expandable environment strings.
  SLDF_RUN_IN_SEPARATE     = $00000400;   // Run the 16-bit target exe in a separate VDM/WOW.
  SLDF_HAS_LOGO3ID         = $00000800;   // The link is a special Logo3/MSICD link.
  SLDF_HAS_DARWINID        = $00001000;   // The link is a special Darwin link.
  SLDF_RUNAS_USER          = $00002000;   // Run the link as a different user.
  SLDF_HAS_EXP_ICON_SZ     = $00004000;   // The link contains expandable env string for icon path.
  SLDF_NO_PIDL_ALIAS       = $00008000;   // Don't ever resolve to a logical location.
  SLDF_FORCE_UNCNAME       = $00010000;   // Make GetPath() prefer the UNC name to the local name.
  SLDF_RUN_WITH_SHIMLAYER  = $00020000;   // Launch the target of this link w/ shim layer active.
  SLDF_RESERVED            = $80000000;   // Reserved-- so we can use the low word as an index value in the future

Type

  DATABLOCK_HEADER = packed record
    cbSize,
    dwSignature : DWORD;
  end;

  EXP_DARWIN_LINK = packed record
    dbh : DATABLOCK_HEADER;
    szDarwinID : array [0..MAX_PATH-1] of char;
    szwDarwinID : array [0..MAX_PATH-1] of word;
  end;

  EXP_SPECIAL_FOLDER = packed record
    dbh : DATABLOCK_HEADER;
    idSpecialFolder,
    cbOffset : DWORD;
  end;

  EXP_SZ_LINK = packed record
    dbh : DATABLOCK_HEADER;
    szTarget : array [0..MAX_PATH-1] of char;
    szwTarget : array [0..MAX_PATH-1] of word;
  end;

  NT_CONSOLE_PROPS = packed record
    dbh : DATABLOCK_HEADER;
    wFillAttribute : WORD;
    wPopupFillAttribute : WORD;
    dwScreenBufferSize : COORD;
    dwWindowSize : COORD;
    dwWindowOrigin : COORD;
    nFont : DWORD;
    nInputBufferSize : DWORD;
    dwFontSize : COORD;
    uFontFamily : UINT;
    uFontWeight : UINT;
    FaceName : array [0..LF_FACESIZE-1] of word;
    uCursorSize : UINT;
    bFullScreen : BOOL;
    bQuickEdit : BOOL;
    bInsertMode : BOOL;
    bAutoPosition : BOOL;
    uHistoryBufferSize : UINT;
    uNumberOfHistoryBuffers : UINT;
    bHistoryNoDup : BOOL;
    ColorTable : array [0..16-1] of COLORREF;
  end;

  NT_FE_CONSOLE_PROPS = packed record
    dbh : DATABLOCK_HEADER;
    uCodePage : UINT;
  end;





{    IShellLinkDataList }
  PIShellLinkDataList = ^IShellLinkDataList;
  IShellLinkDataList = packed record
    vtbl : ^IShellLinkDataListVtbl;
    end;
  IShellLinkDataListVtbl = packed record
    QueryInterface : function (const this : PIShellLinkDataList; const iid: TIID; var obj): HResult; stdcall;
    AddRef : function (const this : PIShellLinkDataList) : ULONG; stdcall;
    Release : function (const this : PIShellLinkDataList) : ULONG; stdcall;
// AddDataBlock Adds a data block to a link.
    AddDataBlock : function (const this : PIShellLinkDataList;PDataBlock : pointer) : ULONG; stdcall;
// CopyDataBlock Retrieves a copy of a link's data block.
    CopyDataBlock : function (const this : PIShellLinkDataList;dwSig : ULONG;var pDataBlock : pointer) : ULONG; stdcall;
// pDataBlock must be freed with LocalFree
// RemoveDataBlock Removes a data block from a link.
    RemoveDataBlock : function (const this : PIShellLinkDataList;dwSig : DWORD) : HResult; stdcall;
// GetFlags Retrieves the current option settings.
    GetFlags : function (const this : PIShellLinkDataList;var dwFlags : DWORD) : HResult; stdcall;
// SetFlags Specifies the current option settings.
    SetFlags : function (const this : PIShellLinkDataList;dwFlags : DWORD) : 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
    pszWorkingDir = path to working directory
    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, pszWorkingDir, 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, pszWorkingDir, pszDesc, pszIconPath : LPSTR; nIconIndex : INT) : hResult;
var
  hres : hResult;
  link : PIShellLink;
  f : PIPersistFile;
  DL : PIShellLinkDataList;
  lszPath : array [0..MAX_PATH] of WCHAR;
  ConsoleProps : NT_CONSOLE_PROPS;
  p : ^NT_CONSOLE_PROPS;
  CodePage : NT_FE_CONSOLE_PROPS;
  pfe :^NT_FE_CONSOLE_PROPS;
  flags : DWORD;
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);
      link^.vtbl^.SetWorkingDirectory (link, pszWorkingDir);
      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;
      if link^.vtbl^.QueryInterface (link, IID_IShellLinkDataList, DL) = S_OK then
        begin
          flags:= DWORD(-1);
          if DL^.vtbl^.GetFlags(DL,flags)=S_OK then
            begin
              writeln('Link flag is ',hexstr(flags,8));
              // flags:=flags or SLDF_RUNAS_USER;
              if DL^.vtbl^.SetFlags(DL,flags)=S_OK then
                Writeln('Flags changed');
              flags:=0;
              DL^.vtbl^.GetFlags(DL,flags);
              writeln('Link flag after is ',hexstr(flags,8));
            end;

          if DL^.vtbl^.CopyDataBlock(DL,NT_CONSOLE_PROPS_SIG,p)=S_OK then
            begin
              ConsoleProps:=p^;
              Writeln('Has NT_CONSOLE_PROPS');
              ConsoleProps.bQuickEdit:=false;
              ConsoleProps.bInsertMode:=false;
              ConsoleProps.bFullScreen:=true;
              LocalFree(longint(p));
            end
          else
            begin
              FillChar(ConsoleProps,sizeof(ConsoleProps),#0);
              ConsoleProps.dbh.cbSize:=sizeof(ConsoleProps);
              ConsoleProps.dbh.dwSignature:=NT_CONSOLE_PROPS_SIG;
              ConsoleProps.wFillAttribute := $07;
              ConsoleProps.wPopupFillAttribute := $5f;
              ConsoleProps.dwScreenBufferSize.X :=80;
              ConsoleProps.dwScreenBufferSize.Y :=500;
              ConsoleProps.dwWindowSize.X:= 70;
              ConsoleProps.dwWindowSize.Y:= 40;
              //ConsoleProps.dwWindowOrigin : COORD;
              //ConsoleProps.nFont : DWORD;
              ConsoleProps.nInputBufferSize:=100;
              ConsoleProps.dwFontSize.X := 8;
              ConsoleProps.dwFontSize.Y := 12;
              //ConsoleProps.uFontFamily : UINT;
              //ConsoleProps.uFontWeight : UINT;
              //ConsoleProps.FaceName : array [0..LF_FACESIZE-1] of word;
              //ConsoleProps.uCursorSize : UINT;
              ConsoleProps.bFullScreen := false;
              ConsoleProps.bQuickEdit := false;
              ConsoleProps.bInsertMode := false;
              ConsoleProps.bAutoPosition := false;
              ConsoleProps.uHistoryBufferSize :=350;
              ConsoleProps.uNumberOfHistoryBuffers := 5;
              ConsoleProps.bHistoryNoDup := true;
              ConsoleProps.ColorTable[0]:=RGB(0,0,0);
              ConsoleProps.ColorTable[1]:=RGB(0,0,128);
              ConsoleProps.ColorTable[2]:=RGB(0,128,0);
              ConsoleProps.ColorTable[3]:=RGB(0,128,128);
              ConsoleProps.ColorTable[4]:=RGB(128,0,0);
              ConsoleProps.ColorTable[5]:=RGB(128,0,128);
              ConsoleProps.ColorTable[6]:=RGB(128,128,0);
              ConsoleProps.ColorTable[7]:=RGB(192,192,192);
              ConsoleProps.ColorTable[8]:=RGB(128,128,128);
              ConsoleProps.ColorTable[9]:=RGB(0,0,255);
              ConsoleProps.ColorTable[10]:=RGB(0,255,0);
              ConsoleProps.ColorTable[11]:=RGB(0,255,255);
              ConsoleProps.ColorTable[12]:=RGB(255,0,0);
              ConsoleProps.ColorTable[13]:=RGB(255,0,255);
              ConsoleProps.ColorTable[14]:=RGB(255,255,0);
              ConsoleProps.ColorTable[15]:=RGB(255,255,255);
              //ConsoleProps.ColorTable : array [0..16-1] of COLORREF;
            end;
          if DL^.vtbl^.AddDataBlock(DL,@ConsoleProps)=S_OK then
            begin
              Writeln('Insert mode successfully changed');
            end;
          if DL^.vtbl^.CopyDataBlock(DL,NT_CONSOLE_PROPS_SIG,p)=S_OK then
            begin
              Writeln('bQuickEdit=',p^.bQuickEdit);
              Writeln('bInsertMode=',p^.bInsertMode);
              Writeln('bFullScreen=',p^.bFullScreen);
              LocalFree(longint(p));
            end;
          if DL^.vtbl^.CopyDataBlock(DL,NT_FE_CONSOLE_PROPS_SIG,pfe)=S_OK then
            begin
              Writeln('Console code page=',pfe^.uCodePage);
              LocalFree(longint(pfe));
            end
          else
            begin
              CodePage.dbh.cbSize:=sizeof(CodePage);
              CodePage.dbh.dwSignature:=NT_FE_CONSOLE_PROPS_SIG;
              CodePage.uCodePage:=437;
              DL^.vtbl^.AddDataBlock(DL,@CodePage);
              if DL^.vtbl^.CopyDataBlock(DL,NT_FE_CONSOLE_PROPS_SIG,pfe)=S_OK then
                begin
                  Writeln('Console code page after=',pfe^.uCodePage);
                  LocalFree(longint(pfe));
                end;
            end;
          DL^.vtbl^.Release (DL);
        end;
      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.