+ create shortcuts under MS Windows

installer/makelink.pas

@@ -0,0 +1,68 @@
+
+program MakeLink;
+
+
+uses
+  Strings,
+  Windows,
+  WinShell;
+
+
+procedure ReadFailure;
+begin
+  Writeln('Reading of config file failed');
+  Halt(1);
+end;
+
+var
+  DesktopPath : PChar;
+  Line,
+  Typ : String;
+  ExeName,
+  LinkName,
+  IconName,
+  Comment,
+  WorkingDir : Array [0..MAX_PATH] of char;
+  f : text;
+
+begin
+  DesktopPath := StrAlloc (MAX_PATH);
+
+  { How could we know if the installer as access to global
+    desktop dir ?? }
+  GetDesktopFolder (true, DesktopPath);
+
+  if (ParamCount=2) and (ParamStr(1)='-F') then
+    begin
+      Assign(f,ParamStr(2));
+      Reset(f);
+      if IOResult<>0 then
+        ReadFailure;
+      while not eof(f) do
+        begin
+          readln(f,line);
+          typ:=copy(line,1,pos('=',line)-1);
+          line:=copy(line,pos('=',line)+1,high(line));
+          if typ='ExePath' then
+            StrPCopy(ExeName,Line);
+          if typ='LinkName' then
+            StrPCopy(LinkName,Line);
+          if typ='IconPath' then
+            StrPCopy(IconName,Line);
+          if typ='Comment' then
+            StrPCopy(Comment,Line);
+          if typ='WorkingDir' then
+            StrPCopy(WorkingDir,Line);
+        end;
+    end;
+  StrCat (DesktopPath, '\');
+  StrCat (DesktopPath,LinkName);
+  CreateShortcut (DesktopPath,
+    ExeName,
+    nil,
+    WorkingDir,
+    Comment,
+    IconName,
+    0);
+  StrDispose (DesktopPath);
+end.

installer/winshell.pas

@@ -0,0 +1,493 @@
+{ 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;
+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:=-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.
+