mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 02:19:22 +01:00
493 lines
21 KiB
ObjectPascal
493 lines
21 KiB
ObjectPascal
{ 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<66> Windows<77> 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.
|