(*:Collection of Win32 wrappers and helper functions.
@desc
Free for personal and commercial use. No rights reserved.
Maintainer : gabr
Contributors : ales, aoven, gabr, Lee_Nover, _MeSSiah_, Miha-R, Odisej, xtreme,
Brdaws, Gre-Gor, krho, Cavlji, radicalb, fora, M.C, MP002
Creation date : 2002-10-09
Last modification : 2008-08-20
Version : 1.41
*)(*
History:
1.41: 2008-08-20
- Tiburon compatibility.
1.40c: 2008-07-14
- Bug fixed: It was not possible to use DSiTimeGetTime64 in parallel from multiple
threads
1.40b: 2008-07-11
- Forced {$T-} as the code doesn't compile in {$T+} state.
1.40a: 2008-06-23
- Added constants FILE_LIST_DIRECTORY, FILE_SHARE_FULL, FILE_ACTION_ADDED,
FILE_ACTION_REMOVED, FILE_ACTION_MODIFIED, FILE_ACTION_RENAMED_OLD_NAME,
FILE_ACTION_RENAMED_NEW_NAME.
1.40: 2008-05-30
- Added function DSiCopyFileAnimated.
1.39: 2008-05-05
- Added function DSiConnectToNetworkResource.
1.38: 2008-04-29
- Added functions to copy HTML format to and from the clipboard:
DSiIsHtmlFormatOnClipboard, DSiGetHtmlFormatFromClipboard,
DSiCopyHtmlFormatToClipboard.
1.37: 2008-03-27
- Created DSiInterlocked*64 family of functions by copying the code from
http://qc.borland.com/wc/qcmain.aspx?d=6212. Functions were written by
Will DeWitt Jr [edge@icehouse.net] and are included with permission.
- Implemented DSiYield.
1.36a: 2008-01-16
- Changed DSiIsAdmin to use big enough buffer for token data.
- Changed DSiIsAdmin to ignore SE_GROUP_ENABLED attribute because function was
sometimes incorrectly returning False.
1.36: 2007-12-29
- Added procedures DSiCenterRectInRect and DSiMakeRectFullyVisibleOnRect.
1.35: 2007-12-17
- Added DSiTerminateProcessById procedure.
1.34: 2007-12-03
- Added three performance counter helpers DSiPerfCounterToMS, DSiPerfCounterToUS,
and DSiQueryPerfCounterAsUS.
1.33: 2007-11-26
- Added function DSiTimeGetTime64.
1.32: 2007-11-13
- Added parameter 'parameters' to DSiCreateShortcut and DSiGetShortcutInfo.
- Added function DSiEditShortcut.
- Added function DSiInitFontToSystemDefault.
1.31: 2007-11-06
- Added SHGetSpecialFolderLocation folder constants: CSIDL_ALTSTARTUP,
CSIDL_CDBURN_AREA, CSIDL_COMMON_ALTSTARTUP, CSIDL_COMMON_DESKTOPDIRECTORY,
CSIDL_COMMON_FAVORITES, CSIDL_COMMON_MUSIC, CSIDL_COMMON_PICTURES,
CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTMENU, CSIDL_COMMON_STARTUP,
CSIDL_COMMON_TEMPLATES, CSIDL_COMMON_VIDEO, CSIDL_COMPUTERSNEARME,
CSIDL_CONNECTIONS, CSIDL_COOKIES, CSIDL_INTERNET, CSIDL_INTERNET_CACHE,
CSIDL_MYDOCUMENTS, CSIDL_MYMUSIC, CSIDL_MYVIDEO, CSIDL_PHOTOALBUMS,
CSIDL_PLAYLISTS, CSIDL_PRINTHOOD, CSIDL_PROFILE, CSIDL_RESOURCES,
CSIDL_SAMPLE_MUSIC, CSIDL_SAMPLE_PLAYLISTS, CSIDL_SAMPLE_PICTURES,
CSIDL_SAMPLE_VIDEOS.
- Added ShGetSpecialFolderLocation flags CSIDL_FLAG_DONT_UNEXPAND and
CSIDL_FLAG_DONT_VERIFY.
- Added dynamically loaded API forwarder DSiSetSuspendState.
- Added dynamically loaded API forwarders DSiEnumProcessModules,
DSiGetModuleFileNameEx, and DSiGetProcessImageFileName.
- Added function DSiGetProcessFileName.
- More stringent checking in DSiGetProcessWindow.
- Fixed DSiLoadLibrary so that it can be called before initialization section is
executed. Somehow, D2007 doesn't always call initialization sectins in correct
order >:-(
1.30: 2007-10-25
- Added dynamically loaded API forwarders DSiDwmEnableComposition and
DsiDwmIsCompositionEnabled.
- Added Aero group with functions DSiAeroDisable, DSiAeroEnable, and
DSiAeroIsEnabled.
1.29: 2007-10-03
- Added function DSiIsAdmin.
1.28a: 2007-09-12
- TDSiTimer properties changed from published to public.
1.28: 2007-07-25
- Added function DSiMoveFile.
- Small changes in DSiMoveOnReboot.
1.27: 2007-07-11
- Added two overloaded functions DSiGetThreadTimes.
1.26: 2007-06-13
- Added two overloaded function DSiFileExtensionIs.
1.25: 2007-05-30
- Added thread-safe alternative to (De)AllocateHwnd - DSi(De)AllocateHwnd.
- Added TDSiTimer - a TTimer clone that uses DSi(De)AllocateHwnd internally.
- New function DSiGetFolderSize.
- Bug fixed: GetProcAddress result was not checked in DSiRegisterActiveX.
1.24: 2007-03-21
- Added support for search depth limitation to DSiEnumFilesEx and
DSiEnumFilesToSL.
1.23: 2007-02-14
- New functions: DSiGetProcessTimes (two overloaded versions), DSiGetFileTimes,
DSiFileTimeToDateTime (two overloaded versions), DSiFileTimeToMicroSeconds,
DSiGetProcessMemoryInfo, DSiGetProcessMemory (two overloaded versions),
DSiIsWow64, DSiGetAppCompatFlags, DSiGetTrueWindowsVersion.
- New dynamically loaded API forwarder: DSiIsWow64Process.
- Added parameter 'access' to DSiReadRegistry, DSiRegistryKeyExists, and
DSiRegistryValueExists functions.
1.22: 2006-12-07
- New function: DSiGetFileTime.
- Added Windows Vista detection to DSiGetWindowsVersion.
1.21: 2006-08-14
- New functions: DSiFileExistsW, DSiDirectoryExistsW, DSiFileSizeW,
DSiCompressFile, DSiUncompressFile, DSiIsFileCompressed, DSiIsFileCompressedW.
1.20: 2006-06-20
- New function: DSiGetShortcutInfo.
1.19: 2006-05-15
- New functions: DSiEnumFilesToSL, DSiGetLongPathName.
1.18: 2006-04-11
- New function: DSiSetDllDirectory.
1.17a: 2006-04-05
- Exit DSiProcessMessages when WM_QUIT is received.
1.17: 2006-03-14
- New function: DSiRegistryValueExists.
- Added 'working dir' parameter to the DSiCreateShortcut function.
1.16: 2006-01-23
- New DSiExecuteAndCapture implementation, contributed by matej.
1.15b: 2005-12-19
- TDSiRegistry.ReadInteger can now also read 4-byte binary values.
1.15a: 2005-08-09
- Removed StrNew from DSiGetComputerName because it caused the result never to
be released.
1.15: 2005-07-11
- New function: DSiWin32CheckNullHandle.
1.14: 2005-06-09
- New function: DSiGetEnvironmentVariable.
- DSiExecuteAndCapture modified to return exit code in a (newly added) parameter
and fixed to work on fast computers.
1.13a: 2005-03-15
- Make DSiGetTempFileName return empty string when GetTempFileName fails.
1.13: 2005-02-12
- New functions: DSiExitWindows, DSiGetSystemLanguage, DSiGetKeyboardLayouts.
- New methods: TDSiRegistry.ReadBinary (two overloaded versions),
TDSiRegistry.WriteBinary (two overloaded versions).
- Added OLE string processing to TDSiRegistry.ReadVariant and
TDSiRegistry.WriteVariant.
- Exported helper functions UTF8Encode and UTF8Decode for old Delphis (D5 and
below).
- Added Windows 2003 detection to DSiGetWindowsVersion.
- Modified DSiEnablePrivilege to return True without doint anything on 9x platform.
- Fixed handle leak in DSiSetProcessPriorityClass.
- Removed some dead code.
- Documented the Information segment.
1.12: 2004-09-21
- Added function DSiIncrementWorkingSet.
1.11: 2004-02-12
- Added functions DSiSetProcessPriorityClass, DSiGetProcessOwnerInfo (two
overloaded versions), DSiEnablePrivilege.
1.10: 2003-12-18
- Updated TDSiRegistry.ReadString to handle DWORD registry values too.
- Updated TDSiRegistry.ReadInteger to handle string registry values too.
1.09: 2003-11-14
- Added functions DSiValidateProcessAffinity, DSiValidateThreadAffinity,
DSiValidateProcessAffinityMask, DSiValidateThreadAffinityMask,
DSiGetSystemAffinityMask, DSiGetProcessAffinityMask,
DSiGetThreadAffinityMask, DSiAffinityMaskToString, and
DSiStringToAffinityMask.
1.08: 2003-11-12
- Added functions DSiCloseHandleAndInvalidate, DSiWin32CheckHandle,
DSiGetSystemAffinity, DSiGetProcessAffinity, DSiSetProcessAffinity,
DSiGetThreadAffinity, DSiSetThreadAffinity.
- Added types TDSiFileHandle, TDSiPipeHandle, TDSiMutexHandle, TDSiEventHandle,
TDSiSemaphoreHandle; all equivaled to THandle.
1.07a: 2003-10-18
- DSiuSecDelay was broken. Fixed.
1.07: 2003-10-09
- Added functions DSiGetUserNameEx, DSiIsDiskInDrive, DSiGetDiskLabel,
DSiGetMyDocumentsFolder, DSiGetSystemVersion, DSiRefreshDesktop,
DSiGetWindowsVersion, DSiRebuildDesktopIcons.
- Added TDSiRegistry methods ReadStrings and WriteStrings dealing with MULTI_SZ
registry format.
1.06a: 2003-09-03
- Typo fixed in DSiMsgWaitForTwoObjectsEx.
1.06: 2003-09-02
- New functions: DSiMsgWaitForTwoObjectsEx, DSiMsgWaitForThreeObjectsEx.
- Documented 'Handles' and 'Registry' sections.
- Bug fixed in DSiLoadLibrary.
1.05: 2003-09-02
- New functions: DSiMonitorOn, DSiMonitorOff, DSiMonitorStandby, DSiGetBootType,
DSiShareFolder, DSiUnshareFolder, DSiFileSize, DSiEnumFiles, DSiEnumFilesEx,
DSiGetDomain, DSiProcessMessages, DSiProcessThreadMessages, DSiLoadLibrary,
DSiGetProcAddress, DSiDisableX, DSiEnableX.
- Added dynamically loaded API forwarders: DSiNetApiBufferFree, DSiNetWkstaGetInfo,
DSiSHEmptyRecycleBin, DSiCreateProcessAsUser, DSiLogonUser,
DSiImpersonateLoggedOnUser, DSiRevertToSelf, DSiCloseServiceHandle,
DSiOpenSCManager, DSi9xNetShareAdd, DSi9xNetShareDel, DSiNTNetShareAdd,
DSiNTNetShareDel.
- DSiGetUserName could fail on Win9x. Fixed.
- Declared constants WAIT_OBJECT_1 (= WAIT_OBJECT_0+1) to WAIT_OBJECT_9
(=WAIT_OBJECT_0+9).
- All dynamically loaded functions are now available to the public (see new
{ DynaLoad } section).
- All functions using dynamically loaded API calls were modified to use new
DynaLoad methods.
- All string parameters turned into 'const' parameters.
- Various constants and type declarations moved to the 'interface' section.
1.04: 2003-05-27
- New functions: DSiLoadMedia, DSiEjectMedia.
1.03: 2003-05-24
- New functions: DSiExecuteAndCapture, DSiFreeMemAndNil.
1.02a: 2003-05-05
- Refuses to compile with Kylix.
- Removed platform-related warnings on Delphi 6&7.
1.02: 2002-12-29
- New function: DSiElapsedSince.
1.01: 2002-12-19
- Compiles with Delphi 6 and Delphi 7.
- New functions:
Files:
procedure DSiDeleteFiles(folder: string; fileMask: string);
procedure DSiDeleteTree(folder: string; removeSubdirsOnly: boolean);
procedure DSiEmptyFolder(folder: string);
procedure DSiEmptyRecycleBin;
procedure DSiRemoveFolder(folder: string);
procedure DSiuSecDelay(delay: word);
Processes:
function DSiExecuteAsUser(const commandLine, username, password: string;
const domain: string = '.'; visibility: integer = SW_SHOWDEFAULT;
workDir: string = ''; wait: boolean = false): cardinal;
function DSiImpersonateUser(const username, password, domain: string): boolean;
procedure DSiStopImpersonatingUser;
1.0: 2002-11-25
- Released.
*)
unit DSiWin32;
{$J+,T-} // required!
interface
{$IFDEF Linux}{$MESSAGE FATAL 'This unit is for Windows only'}{$ENDIF Linux}
{$IFDEF MSWindows}{$WARN SYMBOL_PLATFORM OFF}{$WARN UNIT_PLATFORM OFF}{$ENDIF MSWindows}
{$DEFINE NeedUTF}{$UNDEF NeedVariants}
{$IFDEF ConditionalExpressions}{$UNDEF NeedUTF}{$DEFINE NeedVariants}{$ENDIF}
uses
Windows,
Messages,
Consts,
{$IFDEF NeedVariants}
Variants,
{$ENDIF}
SysUtils,
ShellAPI,
ShlObj,
Classes,
Graphics,
Registry;
const
// pretty wrappers
WAIT_OBJECT_1 = WAIT_OBJECT_0+1;
WAIT_OBJECT_2 = WAIT_OBJECT_0+2;
WAIT_OBJECT_3 = WAIT_OBJECT_0+3;
WAIT_OBJECT_4 = WAIT_OBJECT_0+4;
WAIT_OBJECT_5 = WAIT_OBJECT_0+5;
WAIT_OBJECT_6 = WAIT_OBJECT_0+6;
WAIT_OBJECT_7 = WAIT_OBJECT_0+7;
WAIT_OBJECT_8 = WAIT_OBJECT_0+8;
WAIT_OBJECT_9 = WAIT_OBJECT_0+9;
// folder constants missing from ShellObj
CSIDL_ADMINTOOLS = $0030; //v5.0; \Start Menu\Programs\Administrative Tools
CSIDL_ALTSTARTUP = $001D; //The file system directory that corresponds to the user's nonlocalized Startup program group.
CSIDL_APPDATA = $001A; //v4.71; Application Data, new for NT4
CSIDL_CDBURN_AREA = $003B; //v6.0; The file system directory acting as a staging area for files waiting to be written to CD.
CSIDL_COMMON_ADMINTOOLS = $002F; //v5.0; All Users\Start Menu\Programs\Administrative Tools
CSIDL_COMMON_ALTSTARTUP = $001E; //The file system directory that corresponds to the nonlocalized Startup program group for all users.
CSIDL_COMMON_APPDATA = $0023; //v5.0; All Users\Application Data
CSIDL_COMMON_DESKTOPDIRECTORY = $0019; //The file system directory that contains files and folders that appear on the desktop for all users.
CSIDL_COMMON_DOCUMENTS = $002E; //All Users\Documents
CSIDL_COMMON_FAVORITES = $001F; //The file system directory that serves as a common repository for favorite items common to all users.
CSIDL_COMMON_MUSIC = $0035; //v6.0; The file system directory that serves as a repository for music files common to all users.
CSIDL_COMMON_PICTURES = $0036; //v6.0; The file system directory that serves as a repository for image files common to all users.
CSIDL_COMMON_PROGRAMS = $0017; //The file system directory that contains the directories for the common program groups that appear on the Start menu for all users.
CSIDL_COMMON_STARTMENU = $0016; //The file system directory that contains the programs and folders that appear on the Start menu for all users.
CSIDL_COMMON_STARTUP = $0018; //The file system directory that contains the programs that appear in the Startup folder for all users.
CSIDL_COMMON_TEMPLATES = $002D; //The file system directory that contains the templates that are available to all users.
CSIDL_COMMON_VIDEO = $0037; //v6.0; The file system directory that serves as a repository for video files common to all users.
CSIDL_COMPUTERSNEARME = $003D; //The folder representing other machines in your workgroup.
CSIDL_CONNECTIONS = $0031; //The virtual folder representing Network Connections, containing network and dial-up connections.
CSIDL_COOKIES = $0021; //The file system directory that serves as a common repository for Internet cookies.
CSIDL_HISTORY = $0022; //The file system directory that serves as a common repository for Internet history items.
CSIDL_INTERNET = $0001; //A viritual folder for Internet Explorer (icon on desktop).
CSIDL_INTERNET_CACHE = $0020; //v4.72; The file system directory that serves as a common repository for temporary Internet files.
CSIDL_LOCAL_APPDATA = $001C; //v5.0; non roaming, user\Local Settings\Application Data
CSIDL_MYDOCUMENTS = $000C; //v6.0; The virtual folder representing the My Documents desktop item.
CSIDL_MYMUSIC = $000D; //The file system directory that serves as a common repository for music files.
CSIDL_MYPICTURES = $0027; //v5.0; My Pictures, new for Win2K
CSIDL_MYVIDEO = $000E; //v6.0; The file system directory that serves as a common repository for video files.
CSIDL_PHOTOALBUMS = $0045; //Vista; The virtual folder used to store photo albums.
CSIDL_PLAYLISTS = $003F; //Vista; The virtual folder used to store play albums.
CSIDL_PRINTHOOD = $001B; //The file system directory that contains the link objects that can exist in the Printers virtual folder.
CSIDL_PROFILE = $0028; //v5.0; The user's profile folder.
CSIDL_PROGRAM_FILES = $0026; //v5.0; C:\Program Files
CSIDL_PROGRAM_FILES_COMMON = $002B; //v5.0; C:\Program Files\Common
CSIDL_RESOURCES = $0038; //Vista; The file system directory that contains resource data.
CSIDL_SAMPLE_MUSIC = $0040; //Vista; The file system directory that contains sample music.
CSIDL_SAMPLE_PICTURES = $0042; //Vista; The file system directory that contains sample pictures.
CSIDL_SAMPLE_PLAYLISTS = $0041; //Vista; The file system directory that contains sample playlists.
CSIDL_SAMPLE_VIDEOS = $0043; //Vista; The file system directory that contains sample videos.
CSIDL_SYSTEM = $0025; //v5.0; GetSystemDirectory()
CSIDL_WINDOWS = $0024; //GetWindowsDirectory()
CSIDL_FLAG_DONT_UNEXPAND = $2000; //Combine with another CSIDL constant to ensure expanding of environment variables.
CSIDL_FLAG_DONT_VERIFY = $4000; //Combine with another CSIDL constant, except for CSIDL_FLAG_CREATE, to return an unverified folder path—with no attempt to create or initialize the folder.
CSIDL_FLAG_CREATE = $8000; // new for Win2K, OR this in to force creation of folder
FILE_DEVICE_FILE_SYSTEM = 9;
FILE_DEVICE_MASS_STORAGE = $2D;
METHOD_BUFFERED = 0;
FILE_ANY_ACCESS = 0;
FILE_READ_ACCESS = 1;
FILE_WRITE_ACCESS = 2;
IOCTL_STORAGE_EJECT_MEDIA = (FILE_DEVICE_MASS_STORAGE shl 16) OR
(FILE_READ_ACCESS shl 14) OR
($202 shl 2) OR
(METHOD_BUFFERED);
IOCTL_STORAGE_LOAD_MEDIA = (FILE_DEVICE_MASS_STORAGE shl 16) OR
(FILE_READ_ACCESS shl 14) OR
($203 shl 2) OR
(METHOD_BUFFERED);
FSCTL_SET_COMPRESSION = (FILE_DEVICE_FILE_SYSTEM shl 16) OR
((FILE_READ_ACCESS OR FILE_WRITE_ACCESS) shl 14) OR
(16 shl 2) OR
(METHOD_BUFFERED);
COMPRESSION_FORMAT_NONE = 0;
COMPRESSION_FORMAT_DEFAULT = 1;
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
STYPE_DISKTREE = 0;
SHI50F_RDONLY = $0001;
SHI50F_FULL = $0002;
SHI50F_DEPENDSON = SHI50F_RDONLY or SHI50F_FULL;
SHI50F_ACCESSMASK = SHI50F_RDONLY or SHI50F_FULL;
// IPersisteFile GUID
IID_IPersistFile: TGUID = (
D1: $0000010B; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));
// Extension for shortcut files
CLinkExt = '.lnk';
// ShEmptyRecycleBinA flags
SHERB_NOCONFIRMATION = $00000001;
SHERB_NOPROGRESSUI = $00000002;
SHERB_NOSOUND = $00000004;
// CurrentVersion registry key
DSiWinVerKey9x = '\Software\Microsoft\Windows\CurrentVersion';
DSiWinVerKeyNT = '\Software\Microsoft\Windows NT\CurrentVersion';
DSiWinVerKeys: array [boolean] of string = (DSiWinVerKey9x, DSiWinVerKeyNT);
// CPU IDs for the Affinity familiy of functions
DSiCPUIDs = '0123456789ABCDEFGHIJKLMNOPQRSTUV';
// security constants needed in DSiIsAdmin
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;
DOMAIN_ALIAS_RID_USERS : DWORD = $00000221;
DOMAIN_ALIAS_RID_GUESTS: DWORD = $00000222;
DOMAIN_ALIAS_RID_POWER_: DWORD = $00000223;
SE_GROUP_ENABLED = $00000004;
type
// API types not defined in Delphi 5
PWkstaInfo100 = ^TWkstaInfo100;
_WKSTA_INFO_100 = record
wki100_platform_id: DWORD;
wki100_computername: LPWSTR;
wki100_langroup: LPWSTR;
wki100_ver_major: DWORD;
wki100_ver_minor: DWORD;
end;
{$EXTERNALSYM _WKSTA_INFO_100}
TWkstaInfo100 = _WKSTA_INFO_100;
WKSTA_INFO_100 = _WKSTA_INFO_100;
{$EXTERNALSYM WKSTA_INFO_100}
SHARE_INFO_2_NT = record
shi2_netname: PWideChar;
shi2_type: Integer;
shi2_remark: PWideChar;
shi2_permissions: Integer;
shi2_max_uses: Integer;
shi2_current_uses: Integer;
shi2_path: PWideChar;
shi2_passwd: PWideChar;
end;
SHARE_INFO_50_9x = record
shi50_netname: array[1..13] of char;
shi50_type: byte;
shi50_flags: short;
shi50_remark: pchar;
shi50_path: pchar;
shi50_rw_password: array[1..9] of char;
shi50_ro_password: array[1..9] of char;
szWhatever: array[1..256] of char;
end;
_PROCESS_MEMORY_COUNTERS = packed record
cb: DWORD;
PageFaultCount: DWORD;
PeakWorkingSetSize: DWORD;
WorkingSetSize: DWORD;
QuotaPeakPagedPoolUsage: DWORD;
QuotaPagedPoolUsage: DWORD;
QuotaPeakNonPagedPoolUsage: DWORD;
QuotaNonPagedPoolUsage: DWORD;
PagefileUsage: DWORD;
PeakPagefileUsage: DWORD;
end;
PROCESS_MEMORY_COUNTERS = _PROCESS_MEMORY_COUNTERS;
PPROCESS_MEMORY_COUNTERS = ^_PROCESS_MEMORY_COUNTERS;
TProcessMemoryCounters = _PROCESS_MEMORY_COUNTERS;
PProcessMemoryCounters = ^_PROCESS_MEMORY_COUNTERS;
// Service Controller handle
SC_HANDLE = THandle;
// DSiEnumFiles callback
TDSiEnumFilesCallback = procedure(const longFileName: string) of object;
// DSiEnumFilesEx callback
TDSiEnumFilesExCallback = procedure(const folder: string; S: TSearchRec;
isAFolder: boolean; var stopEnum: boolean) of object;
TDSiFileTime = (ftCreation, ftLastAccess, ftLastModification);
{ Handles }
// Pretty-print aliases
TDSiFileHandle = THandle;
TDSiPipeHandle = THandle;
TDSiMutexHandle = THandle;
TDSiEventHandle = THandle;
TDSiSemaphoreHandle = THandle;
procedure DSiCloseHandleAndInvalidate(var handle: THandle);
procedure DSiCloseHandleAndNull(var handle: THandle);
function DSiMsgWaitForThreeObjectsEx(obj0, obj1, obj2: THandle;
timeout: DWORD; wakeMask: DWORD; flags: DWORD): DWORD;
function DSiMsgWaitForTwoObjectsEx(obj0, obj1: THandle; timeout: DWORD;
wakeMask: DWORD; flags: DWORD): DWORD;
function DSiWaitForThreeObjects(obj0, obj1, obj2: THandle; waitAll: boolean;
timeout: DWORD): DWORD;
function DSiWaitForThreeObjectsEx(obj0, obj1, obj2: THandle; waitAll: boolean;
timeout: DWORD; alertable: boolean): DWORD;
function DSiWaitForTwoObjects(obj0, obj1: THandle; waitAll: boolean;
timeout: DWORD): DWORD;
function DSiWaitForTwoObjectsEx(obj0, obj1: THandle; waitAll: boolean;
timeout: DWORD; alertable: boolean): DWORD;
function DSiWin32CheckHandle(handle: THandle): THandle;
function DSiWin32CheckNullHandle(handle: THandle): THandle;
{ Registry }
const
KEY_WOW64_64KEY = $0100;
type
TDSiRegistry = class(TRegistry)
function ReadBinary(const name, defval: string): string; overload;
function ReadBinary(const name: string; dataStream: TStream): boolean; overload;
function ReadBool(const name: string; defval: boolean): boolean;
function ReadDate(const name: string; defval: TDateTime): TDateTime;
function ReadFont(const name: string; font: TFont): boolean;
function ReadInt64(const name: string; defval: int64): int64;
function ReadInteger(const name: string; defval: integer): integer;
function ReadString(const name, defval: string): string;
procedure ReadStrings(const name: string; strings: TStrings);
function ReadVariant(const name: string; defval: variant): variant;
procedure WriteBinary(const name, data: string); overload;
procedure WriteBinary(const name: string; data: TStream); overload;
procedure WriteFont(const name: string; font: TFont);
procedure WriteInt64(const name: string; value: int64);
procedure WriteStrings(const name: string; strings: TStrings);
procedure WriteVariant(const name: string; value: variant);
end; { TDSiRegistry }
function DSiCreateRegistryKey(const registryKey: string;
root: HKEY = HKEY_CURRENT_USER): boolean;
function DSiKillRegistry(const registryKey: string;
root: HKEY = HKEY_CURRENT_USER): boolean;
function DSiReadRegistry(const registryKey, name: string;
defaultValue: Variant; root: HKEY = HKEY_CURRENT_USER;
access: longword = KEY_QUERY_VALUE): Variant; overload;
function DSiReadRegistry(const registryKey, name: string;
defaultValue: int64; root: HKEY = HKEY_CURRENT_USER;
access: longword = KEY_QUERY_VALUE): int64; overload;
function DSiRegistryKeyExists(const registryKey: string;
root: HKEY = HKEY_CURRENT_USER; access: longword = KEY_QUERY_VALUE): boolean;
function DSiRegistryValueExists(const registryKey, name: string;
root: HKEY = HKEY_CURRENT_USER; access: longword = KEY_QUERY_VALUE): boolean;
function DSiWriteRegistry(const registryKey, name: string; value: int64;
root: HKEY = HKEY_CURRENT_USER): boolean; overload;
function DSiWriteRegistry(const registryKey, name: string; value: Variant;
root: HKEY = HKEY_CURRENT_USER): boolean; overload;
{ Files }
type
TShFileOpFlag = (fofAllowUndo, fofFilesOnly, fofMultiDestFiles, fofNoConfirmation,
fofNoConfirmMkDir, fofNoConnectedElements, fofNoErrorUI, fofNoRecursion,
fofNoRecurseReparse, fofRenameOnCollision, fofSilent, fofSimpleProgress,
fofWantMappingHandle, fofWantNukeWarning, fofNoUI);
TShFileOpFlags = set of TShFileOpFlag;
const
FILE_LIST_DIRECTORY = $0001;
FILE_SHARE_FULL = FILE_SHARE_DELETE OR FILE_SHARE_READ OR FILE_SHARE_WRITE;
FILE_ACTION_ADDED = $00000001;
FILE_ACTION_REMOVED = $00000002;
FILE_ACTION_MODIFIED = $00000003;
FILE_ACTION_RENAMED_OLD_NAME = $00000004;
FILE_ACTION_RENAMED_NEW_NAME = $00000005;
FOF_NOCONNECTEDELEMENTS = $2000;
FOF_NORECURSION = $1000;
FOF_NORECURSEREPARSE = $8000;
FOF_WANTNUKEWARNING = $4000;
FOF_NO_UI = FOF_SILENT OR FOF_NOCONFIRMATION OR FOF_NOERRORUI OR FOF_NOCONFIRMMKDIR;
CShFileOpFlagMappings: array [TShFileOpFlag] of FILEOP_FLAGS = (FOF_ALLOWUNDO,
FOF_FILESONLY, FOF_MULTIDESTFILES, FOF_NOCONFIRMATION, FOF_NOCONFIRMMKDIR,
FOF_NOCONNECTEDELEMENTS, FOF_NOERRORUI, FOF_NORECURSION, FOF_NORECURSEREPARSE,
FOF_RENAMEONCOLLISION, FOF_SILENT, FOF_SIMPLEPROGRESS, FOF_WANTMAPPINGHANDLE,
FOF_WANTNUKEWARNING, FOF_NO_UI);
function DSiCanWriteToFolder(const folderName: string): boolean;
function DSiCompressFile(fileHandle: THandle): boolean;
function DSiConnectToNetworkResource(const networkResource: string; const mappedLetter:
string = ''; const username: string = ''; const password: string = ''): boolean;
function DSiCopyFileAnimated(ownerWindowHandle: THandle; sourceFile, destinationFile:
string; var aborted: boolean; flags: TShFileOpFlags = [fofNoConfirmMkDir]): boolean;
function DSiCreateTempFolder: string;
procedure DSiDeleteFiles(const folder, fileMask: string);
function DSiDeleteOnReboot(const fileName: string): boolean;
procedure DSiDeleteTree(const folder: string; removeSubdirsOnly: boolean);
function DSiDeleteWithBatch(const fileName: string; rmDir: boolean = false): boolean;
function DSiDirectoryExistsW(const directory: WideString): boolean;
function DSiEjectMedia(deviceLetter: char): boolean;
procedure DSiEmptyFolder(const folder: string);
function DSiEmptyRecycleBin: boolean;
function DSiEnumFiles(const fileMask: string; attr: integer;
enumCallback: TDSiEnumFilesCallback): integer;
function DSiEnumFilesEx(const fileMask: string; attr: integer;
enumSubfolders: boolean; enumCallback: TDSiEnumFilesExCallback;
maxEnumDepth: integer = 0): integer;
procedure DSiEnumFilesToSL(const fileMask: string; attr: integer; fileList: TStrings;
storeFullPath: boolean = false; enumSubfolders: boolean = false;
maxEnumDepth: integer = 0);
function DSiFileExistsW(const fileName: WideString): boolean;
function DSiFileExtensionIs(const fileName, extension: string): boolean; overload;
function DSiFileExtensionIs(const fileName: string; extension: array of string):
boolean; overload;
function DSiFileSize(const fileName: string): int64;
function DSiFileSizeW(const fileName: WideString): int64;
function DSiGetFolderSize(const folder: string; includeSubfolders: boolean): int64;
function DSiGetFileTime(const fileName: string; whatTime: TDSiFileTime): TDateTime;
function DSiGetFileTimes(const fileName: string; var creationTime, lastAccessTime,
lastModificationTime: TDateTime): boolean;
function DSiGetLongPathName(const fileName: string): string;
function DSiGetTempFileName(const prefix: string; const tempPath: string = ''): string;
function DSiGetTempPath: string;
function DSiGetUniqueFileName(const extension: string): string;
function DSiIsFileCompressed(const fileName: string): boolean;
function DSiIsFileCompressedW(const fileName: WideString): boolean;
function DSiKillFile(const fileName: string): boolean;
function DSiLoadMedia(deviceLetter: char): boolean;
function DSiMoveFile(const srcName, destName: string; overwrite: boolean = true): boolean;
function DSiMoveOnReboot(const srcName, destName: string): boolean;
procedure DSiRemoveFolder(const folder: string);
function DSiShareFolder(const folder, shareName, comment: string): boolean;
function DSiUncompressFile(fileHandle: THandle): boolean;
function DSiUnShareFolder(const shareName: string): boolean;
{ Processes }
function DSiAffinityMaskToString(affinityMask: DWORD): string;
function DSiEnablePrivilege(const privilegeName: string): boolean;
function DSiExecute(const commandLine: string;
visibility: integer = SW_SHOWDEFAULT; const workDir: string = '';
wait: boolean = false): cardinal;
function DSiExecuteAndCapture(const app: string; output: TStrings;
const workDir: string; var exitCode: longword): cardinal;
function DSiExecuteAsUser(const commandLine, username, password: string;
const domain: string = '.'; visibility: integer = SW_SHOWDEFAULT;
const workDir: string = ''; wait: boolean = false): cardinal;
function DSiGetProcessAffinity: string;
function DSiGetProcessAffinityMask: DWORD;
function DSiGetProcessID(const processName: string; var processID: DWORD): boolean;
function DSiGetProcessMemory(var memoryCounters: TProcessMemoryCounters): boolean;
overload;
function DSiGetProcessMemory(process: THandle; var memoryCounters:
TProcessMemoryCounters): boolean; overload;
function DSiGetProcessFileName(process: THandle; var processName: string): boolean;
function DSiGetProcessOwnerInfo(const processName: string; var user,
domain: string): boolean; overload;
function DSiGetProcessOwnerInfo(processID: DWORD; var user,
domain: string): boolean; overload;
function DSiGetProcessTimes(var creationTime: TDateTime; var userTime,
kernelTime: int64): boolean; overload;
function DSiGetProcessTimes(process: THandle; var creationTime, exitTime: TDateTime;
var userTime, kernelTime: int64): boolean; overload;
function DSiGetSystemAffinity: string;
function DSiGetSystemAffinityMask: DWORD;
function DSiGetThreadAffinity: string;
function DSiGetThreadAffinityMask: DWORD;
function DSiGetThreadTimes(var creationTime: TDateTime; var userTime,
kernelTime: int64): boolean; overload;
function DSiGetThreadTimes(thread: THandle; var creationTime, exitTime: TDateTime;
var userTime, kernelTime: int64): boolean; overload;
function DSiImpersonateUser(const username, password: string;
const domain: string = '.'): boolean;
function DSiIncrementWorkingSet(incMinSize, incMaxSize: integer): boolean;
function DSiIsDebugged: boolean;
function DSiOpenURL(const URL: string; newBrowser: boolean = false): boolean;
procedure DSiProcessThreadMessages;
function DSiRealModuleName: string;
function DSiSetProcessAffinity(affinity: string): string;
function DSiSetProcessPriorityClass(const processName: string;
priority: DWORD): boolean;
function DSiSetThreadAffinity(affinity: string): string;
procedure DSiStopImpersonatingUser;
function DSiStringToAffinityMask(affinity: string): DWORD;
function DSiTerminateProcessById(processID: DWORD; closeWindowsFirst: boolean = true;
maxWait_sec: integer = 10): boolean;
procedure DSiTrimWorkingSet;
function DSiValidateProcessAffinity(affinity: string): string;
function DSiValidateProcessAffinityMask(affinityMask: DWORD): DWORD;
function DSiValidateThreadAffinity(affinity: string): string;
function DSiValidateThreadAffinityMask(affinityMask: DWORD): DWORD;
procedure DSiYield;
{ Memory }
procedure DSiFreePidl(pidl: PItemIDList);
procedure DSiFreeMemAndNil(var mem: pointer);
{ Windows }
type
TDSiExitWindows = (ewLogOff, ewForcedLogOff, ewPowerOff, ewForcedPowerOff, ewReboot,
ewForcedReboot, ewShutdown, ewForcedShutdown);
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
procedure DSiDeallocateHWnd(wnd: HWND);
procedure DSiDisableX(hwnd: THandle);
procedure DSiEnableX(hwnd: THandle);
function DSiExitWindows(exitType: TDSiExitWindows): boolean;
function DSiForceForegroundWindow(hwnd: THandle;
restoreFirst: boolean = true): boolean;
function DSiGetClassName(hwnd: THandle): string;
function DSiGetProcessWindow(targetProcessID: cardinal): HWND;
function DSiGetWindowText(hwnd: THandle): string;
procedure DSiProcessMessages(hwnd: THandle; waitForWMQuit: boolean = false);
procedure DSiRebuildDesktopIcons;
procedure DSiRefreshDesktop;
procedure DSiSetTopMost(hwnd: THandle; onTop: boolean = true;
activate: boolean = false);
{ Aero }
function DSiAeroDisable: boolean;
function DSiAeroEnable: boolean;
function DSiAeroIsEnabled: boolean;
{ Taskbar }
function DSiGetTaskBarPosition: integer;
{ Menus }
function DSiGetHotkey(const item: string): char;
function DSiGetMenuItem(menu: HMENU; item: integer): string;
{ Screen }
procedure DSiDisableScreenSaver(out currentlyActive: boolean);
procedure DSiEnableScreenSaver;
function DSiGetBitsPerPixel: integer;
function DSiGetBPP: integer;
function DSiGetDesktopSize: TRect;
function DSiIsFullScreen: boolean;
procedure DSiMonitorOff;
procedure DSiMonitorOn;
procedure DSiMonitorStandby;
function DSiSetScreenResolution(width, height: integer): longint;
{ Rectangles }
procedure DSiCenterRectInRect(const ownerRect: TRect; var clientRect: TRect);
procedure DSiMakeRectFullyVisibleOnRect(const ownerRect: TRect; var clientRect: TRect);
{ Clipboard }
function DSiIsHtmlFormatOnClipboard: boolean;
function DSiGetHtmlFormatFromClipboard: string;
procedure DSiCopyHtmlFormatToClipboard(const sHtml: string; const sText: string = '');
{ Information }
type
TDSiBootType = (btNormal, btFailSafe, btFailSafeWithNetwork, btUnknown);
TDSiWindowsVersion = (wvUnknown, wvWin31, wvWin95, wvWin95OSR2, wvWin98,
wvWin98SE, wvWinME, wvWin9x, wvWinNT3, wvWinNT4, wvWin2000, wvWinXP,
wvWinNT, wvWinServer2003, wvWinVista);
TDSiUIElement = (ueMenu, ueMessage, ueWindowCaption, ueStatus);
const
CDSiWindowsVersionStr: array [TDSiWindowsVersion] of string = ('Unknown',
'Windows 3.1', 'Windows 95', 'Windows 95 OSR 2', 'Windows 98',
'Windows 98 SE', 'Windows Me', 'Windows 9x', 'Windows NT 3.5',
'Windows NT 4', 'Windows 2000', 'Windows XP', 'Windows NT', 'Windows Server 2003',
'Windows Vista');
function DSiGetAppCompatFlags(const exeName: string): string;
function DSiGetBootType: TDSiBootType;
function DSiGetCompanyName: string;
function DSiGetComputerName: string;
function DSiGetDefaultBrowser: string;
function DSiGetDirectXVer: string;
function DSiGetDiskLabel(disk: char): string;
function DSiGetDiskSerial(disk: char): string;
function DSiGetDomain: string;
function DSiGetEnvironmentVariable(const envVarName: string): string;
function DSiGetFolderLocation(const CSIDL: integer): string;
procedure DSiGetKeyboardLayouts(layouts: TStrings);
function DSiGetMyDocumentsFolder: string;
function DSiGetProgramFilesFolder: string;
function DSiGetRegisteredOwner: string;
function DSiGetSystemFolder: string;
function DSiGetSystemLanguage: string;
function DSiGetSystemVersion: string;
function DSiGetTrueWindowsVersion: TDSiWindowsVersion;
function DSiGetUserName: string;
function DSiGetUserNameEx: string;
function DSiGetWindowsFolder: string;
function DSiGetWindowsVersion: TDSiWindowsVersion;
function DSiInitFontToSystemDefault(aFont: TFont; aElement: TDSiUIElement): boolean;
function DSiIsAdmin: boolean;
function DSiIsAdminLoggedOn: boolean;
function DSiIsDiskInDrive(disk: char): boolean;
function DSiIsWinNT: boolean;
function DSiIsWow64: boolean;
{ Install }
function DSiAddUninstallInfo(const displayName, uninstallCommand, publisher,
URLInfoAbout, displayVersion, helpLink, URLUpdateInfo: string): boolean;
function DSiAutoRunApp(const applicationName, applicationPath: string;
enabled: boolean = true): boolean;
procedure DSiCreateShortcut(const fileName, displayName, parameters: string;
folder: integer = CSIDL_STARTUP; const workDir: string = '');
function DSiDeleteShortcut(const displayName: string;
folder: integer = CSIDL_STARTUP): boolean;
procedure DSiEditShortcut(const lnkName, fileName, workDir, parameters: string);
function DSiGetShortcutInfo(const lnkName: string; var fileName, filePath, workDir,
parameters: string): boolean;
function DSiGetUninstallInfo(const displayName: string;
out uninstallCommand: string): boolean;
function DSiIsAutoRunApp(const applicationname: string): boolean;
function DSiRegisterActiveX(const fileName: string; registerDLL: boolean): HRESULT;
procedure DSiRegisterRunOnce(const applicationName,
applicationPath: string);
procedure DSiRemoveRunOnce(const applicationName: string);
function DSiRemoveUninstallInfo(const displayName: string): boolean;
function DSiShortcutExists(const displayName: string;
folder: integer = CSIDL_STARTUP): boolean;
{ Time }
type
{:TTimer clone that uses DSiAllocateHwnd/DSiDeallocateHwnd instead of Delphi's
AllocateHwnd/DeallocateHwnd. Intented to be dynamically created in threads and
therefore not a TComponent descendant.
@author gabr
@since 2007-05-30
}
TDSiTimer = class
private
dtEnabled : boolean;
dtInterval : cardinal;
dtOnTimer : TNotifyEvent;
dtTag : longint;
dtWindowHandle: HWND;
protected
procedure SetEnabled(value: boolean);
procedure SetInterval(value: cardinal);
procedure SetOnTimer(value: TNotifyEvent);
procedure UpdateTimer;
procedure WndProc(var msgRec: TMessage);
public
constructor Create(enabled: boolean = true; interval: cardinal = 1000; onTimer:
TNotifyEvent = nil; tag: longint = 0);
destructor Destroy; override;
property Enabled: boolean read dtEnabled write SetEnabled default true;
property Interval: cardinal read dtInterval write SetInterval default 1000;
property Tag: longint read dtTag write dtTag;
property OnTimer: TNotifyEvent read dtOnTimer write SetOnTimer;
end; { TDSiTimer }
//Following three functions are based on GetTickCount
function DSiElapsedSince(midTime, startTime: int64): int64;
function DSiElapsedTime(startTime: int64): int64;
function DSiHasElapsed(startTime: int64; timeout: DWORD): boolean;
function DSiFileTimeToDateTime(fileTime: TFileTime): TDateTime; overload;
function DSiFileTimeToDateTime(fileTime: TFileTime; var dateTime: TDateTime): boolean; overload;
function DSiFileTimeToMicroSeconds(fileTime: TFileTime): int64;
function DSiPerfCounterToMS(perfCounter: int64): int64;
function DSiPerfCounterToUS(perfCounter: int64): int64;
function DSiQueryPerfCounterAsUS: int64;
function DSiTimeGetTime64: int64;
procedure DSiuSecDelay(delay: int64);
{ Interlocked }
function DSiInterlockedDecrement64(var addend: int64): int64; register;
function DSiInterlockedIncrement64(var addend: int64): int64; register;
function DSiInterlockedExchangeAdd64(var addend: int64; value: int64): int64; register;
function DSiInterlockedExchange64(var target: int64; value: int64): int64; register;
function DSiInterlockedCompareExchange64(var destination: int64; exchange, comparand: int64): int64; register; overload;
function DSiInterlockedCompareExchange64(destination: PInt64; exchange, comparand: int64): int64; register; overload;
{ DynaLoad }
const // composition action values for DSiDwmEnableComposition
DWM_EC_DISABLECOMPOSITION = 0;
DWM_EC_ENABLECOMPOSITION = 1;
type
PModule = ^HMODULE;
function DSi9xNetShareAdd(serverName: PChar; shareLevel: smallint;
buffer: pointer; size: word): integer; stdcall;
function DSi9xNetShareDel(serverName: PChar; netName: PChar;
reserved: word): integer; stdcall;
function DSiCloseServiceHandle(hSCObject: SC_HANDLE): BOOL; stdcall;
function DSiCreateProcessAsUser(hToken: THandle;
lpApplicationName, lpCommandLine: PChar; lpProcessAttributes,
lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL;
dwCreationFlags: DWORD; lpEnvironment: pointer;
lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
function DSiDwmEnableComposition(uCompositionAction: UINT): HRESULT; stdcall;
function DSiDwmIsCompositionEnabled(var pfEnabled: BOOL): HRESULT; stdcall;
function DSiEnumProcessModules(hProcess: THandle; lphModule: PModule; cb: DWORD;
var lpcbNeeded: DWORD): BOOL; stdcall;
function DSiGetModuleFileNameEx(hProcess: THandle; hModule: HMODULE; lpFilename: PChar;
nSize: DWORD): DWORD; stdcall;
function DSiGetProcessImageFileName(hProcess: THandle; lpImageFileName: PChar;
nSize: DWORD): DWORD; stdcall;
function DSiGetProcessMemoryInfo(process: THandle; memCounters: PProcessMemoryCounters;
cb: DWORD): boolean; stdcall;
function DSiImpersonateLoggedOnUser(hToken: THandle): BOOL; stdcall;
function DSiIsWow64Process(hProcess: THandle; var wow64Process: BOOL): BOOL; stdcall;
function DSiLogonUser(lpszUsername, lpszDomain, lpszPassword: PChar;
dwLogonType, dwLogonProvider: DWORD; var phToken: THandle): BOOL; stdcall;
function DSiNetApiBufferFree(buffer: pointer): cardinal; stdcall;
function DSiNetWkstaGetInfo(servername: PChar; level: cardinal;
out bufptr: Pointer): cardinal; stdcall;
function DSiNTNetShareAdd(serverName: PChar; level: integer; buf: PChar;
var parm_err: integer): DWord; stdcall;
function DSiNTNetShareDel(serverName: PChar; netName: PWideChar;
reserved: integer): DWord; stdcall;
function DSiOpenSCManager(lpMachineName, lpDatabaseName: PChar;
dwDesiredAccess: DWORD): SC_HANDLE; stdcall;
function DSiRevertToSelf: BOOL; stdcall;
function DSiSetDllDirectory(path: PChar): boolean; stdcall;
function DSiSetSuspendState(hibernate: BOOL; forceCritical: BOOL = false;
disableWakeEvent: BOOL = false): BOOL; stdcall;
function DSiSHEmptyRecycleBin(Wnd: HWND; pszRootPath: PChar;
dwFlags: DWORD): HRESULT; stdcall;
{ Helpers }
{$IFDEF NeedUTF}
// UTF <-> 16-bit conversion. Same signature as D7 functions but custom implementation
// (taken from http://gp.17slon.com/gp/gptextstream.htm with permission).
type
UTF8String = type string;
PUTF8String = ^UTF8String;
function UTF8Encode(const ws: WideString): UTF8String;
function UTF8Decode(const sUtf: UTF8String): WideString;
{$ENDIF NeedUTF}
implementation
uses
Types,
ComObj,
ActiveX,
FileCtrl,
{$IFDEF CONDITIONALCOMPILATION}
Variants,
{$ENDIF}
TLHelp32,
MMSystem;
type
T9xNetShareAdd = function(serverName: PChar; shareLevel: smallint;
buffer: pointer; size: word): integer; stdcall;
T9xNetShareDel = function(serverName: PChar; netName: PChar;
reserved: word): integer; stdcall;
TCloseServiceHandle = function(hSCObject: SC_HANDLE): BOOL; stdcall;
TCreateProcessAsUser = function(hToken: THandle;
lpApplicationName: PAnsiChar; lpCommandLine: PAnsiChar; lpProcessAttributes,
lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL;
dwCreationFlags: DWORD; lpEnvironment: pointer;
lpCurrentDirectory: PAnsiChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL; stdcall;
TDwmEnableComposition = function(uCompositionAction: UINT): HRESULT; stdcall;
TDwmIsCompositionEnabled = function(var pfEnabled: BOOL): HRESULT; stdcall;
TEnumProcessModules = function(hProcess: THandle; lphModule: PModule; cb: DWORD;
var lpcbNeeded: DWORD): BOOL; stdcall;
TGetLongPathName = function(lpszShortPath, lpszLongPath: PChar;
cchBuffer: DWORD): DWORD; stdcall;
TGetModuleFileNameEx = function(hProcess: THandle; hModule: HMODULE; lpFilename: PChar;
nSize: DWORD): DWORD; stdcall;
TGetProcessImageFileName = function(hProcess: THandle; lpImageFileName: PChar;
nSize: DWORD): DWORD; stdcall;
TGetProcessMemoryInfo = function(process: THandle; memCounters: PProcessMemoryCounters;
cb: DWORD): boolean; stdcall;
TImpersonateLoggedOnUser = function(hToken: THandle): BOOL; stdcall;
TIsWow64Process = function(hProcess: THandle; var wow64Process: BOOL): BOOL; stdcall;
TLogonUser = function(lpszUsername, lpszDomain, lpszPassword: LPCSTR;
dwLogonType, dwLogonProvider: DWORD; var phToken: THandle): BOOL; stdcall;
TNetApiBufferFree = function(buffer: pointer): cardinal; stdcall;
TNetWkstaGetInfo = function(servername: PChar; level: cardinal;
out bufptr: Pointer): cardinal; stdcall;
TNTNetShareAdd = function(serverName: PChar; level: integer; buf: PChar;
var parm_err: integer): DWord; stdcall;
TNTNetShareDel = function(serverName: PChar; netName: PWideChar;
reserved: integer): DWord; stdcall;
TOpenSCManager = function(lpMachineName, lpDatabaseName: PChar;
dwDesiredAccess: DWORD): SC_HANDLE; stdcall;
TRevertToSelf = function: BOOL; stdcall;
TSetDllDirectory = function(path: PChar): boolean; stdcall;
TSetSuspendState = function(hibernate, forceCritical, disableWakeEvent: BOOL): BOOL; stdcall;
TSHEmptyRecycleBin = function(wnd: HWND; pszRootPath: PChar;
dwFlags: DWORD): HRESULT; stdcall;
const
G9xNetShareAdd: T9xNetShareAdd = nil;
G9xNetShareDel: T9xNetShareDel = nil;
GCloseServiceHandle: TCloseServiceHandle = nil;
GCreateProcessAsUser: TCreateProcessAsUser = nil;
GDwmEnableComposition: TDwmEnableComposition = nil;
GDwmIsCompositionEnabled: TDwmIsCompositionEnabled = nil;
GEnumProcessModules: TEnumProcessModules = nil;
GGetModuleFileNameEx: TGetModuleFileNameEx = nil;
GGetLongPathName: TGetLongPathName = nil;
GGetProcessImageFileName: TGetProcessImageFileName = nil;
GGetProcessMemoryInfo: TGetProcessMemoryInfo = nil;
GImpersonateLoggedOnUser: TImpersonateLoggedOnUser = nil;
GIsWow64Process: TIsWow64Process = nil;
GLogonUser: TLogonUser = nil;
GNetApiBufferFree: TNetApiBufferFree = nil;
GNetWkstaGetInfo: TNetWkstaGetInfo = nil;
GNTNetShareAdd: TNTNetShareAdd = nil;
GNTNetShareDel: TNTNetShareDel = nil;
GOpenSCManager: TOpenSCManager = nil;
GRevertToSelf: TRevertToSelf = nil;
GSetDllDirectory: TSetDllDirectory = nil;
GSetSuspendState: TSetSuspendState = nil;
GSHEmptyRecycleBin: TSHEmptyRecycleBin = nil;
function DSiGetProcAddress(const libFileName, procName: string): FARPROC; forward;
{ Helpers }
function FileOpenSafe(fileName: string; var fileHandle: textfile;
diskRetryDelay, diskRetryCount: integer): boolean;
var
dum: integer;
begin
Assign (fileHandle, fileName);
{$I-}
repeat
if FileExists(fileName) then
Reset(fileHandle)
else
Rewrite (fileHandle);
dum := IOResult;
if (dum in [ERROR_SHARING_VIOLATION, ERROR_LOCK_VIOLATION]) and
(diskRetryDelay > 0) then
begin
Sleep(diskRetryDelay);
if diskRetryCount > 0 then Dec(diskRetryCount);
end;
until (not (dum in [ERROR_SHARING_VIOLATION, ERROR_LOCK_VIOLATION])) or
(diskRetryCount = 0);
{$I+}
Result := (dum = 0);
end; { FileOpenSafe }
{$IFDEF NeedUTF}
{:Convers buffer of WideChars into UTF-8 encoded form. Target buffer must be
pre-allocated and large enough (each WideChar will use at most three bytes
in UTF-8 encoding).
RFC 2279 (http://www.ietf.org/rfc/rfc2279.txt) describes the conversion:
$0000..$007F => $00..$7F
$0080..$07FF => 110[bit10..bit6] 10[bit5..bit0]
$0800..$FFFF => 1110[bit15..bit12] 10[bit11..bit6] 10[bit5..bit0]
@param unicodeBuf Buffer of WideChars.
@param uniByteCount Size of unicodeBuf, in bytes.
@param utf8Buf Pre-allocated buffer for UTF-8 encoded result.
@returns Number of bytes used in utf8Buf buffer.
@since 2.01
}
function WideCharBufToUTF8Buf(const unicodeBuf; uniByteCount: integer;
var utf8Buf): integer;
var
iwc: integer;
pch: PChar;
pwc: PWideChar;
wc : word;
procedure AddByte(b: byte);
begin
pch^ := char(b);
Inc(pch);
end; { AddByte }
begin { WideCharBufToUTF8Buf }
pwc := @unicodeBuf;
pch := @utf8Buf;
for iwc := 1 to uniByteCount div SizeOf(WideChar) do begin
wc := Ord(pwc^);
Inc(pwc);
if (wc >= $0001) and (wc <= $007F) then begin
AddByte(wc AND $7F);
end
else if (wc >= $0080) and (wc <= $07FF) then begin
AddByte($C0 OR ((wc SHR 6) AND $1F));
AddByte($80 OR (wc AND $3F));
end
else begin // (wc >= $0800) and (wc <= $FFFF)
AddByte($E0 OR ((wc SHR 12) AND $0F));
AddByte($80 OR ((wc SHR 6) AND $3F));
AddByte($80 OR (wc AND $3F));
end;
end; //for
Result := integer(pch)-integer(@utf8Buf);
end; { WideCharBufToUTF8Buf }
{:Converts UTF-8 encoded buffer into WideChars. Target buffer must be
pre-allocated and large enough (at most utfByteCount number of WideChars will
be generated).
RFC 2279 (http://www.ietf.org/rfc/rfc2279.txt) describes the conversion:
$00..$7F => $0000..$007F
110[bit10..bit6] 10[bit5..bit0] => $0080..$07FF
1110[bit15..bit12] 10[bit11..bit6] 10[bit5..bit0] => $0800..$FFFF
@param utf8Buf UTF-8 encoded buffer.
@param utfByteCount Size of utf8Buf, in bytes.
@param unicodeBuf Pre-allocated buffer for WideChars.
@param leftUTF8 Number of bytes left in utf8Buf after conversion (0, 1,
or 2).
@returns Number of bytes used in unicodeBuf buffer.
@since 2.01
}
function UTF8BufToWideCharBuf(const utf8Buf; utfByteCount: integer;
var unicodeBuf; var leftUTF8: integer): integer;
var
c1 : byte;
c2 : byte;
ch : byte;
pch: PChar;
pwc: PWideChar;
begin
pch := @utf8Buf;
pwc := @unicodeBuf;
leftUTF8 := utfByteCount;
while leftUTF8 > 0 do begin
ch := byte(pch^);
Inc(pch);
if (ch AND $80) = 0 then begin // 1-byte code
word(pwc^) := ch;
Inc(pwc);
Dec(leftUTF8);
end
else if (ch AND $E0) = $C0 then begin // 2-byte code
if leftUTF8 < 2 then
break;
c1 := byte(pch^);
Inc(pch);
word(pwc^) := (word(ch AND $1F) SHL 6) OR (c1 AND $3F);
Inc(pwc);
Dec(leftUTF8,2);
end
else begin // 3-byte code
if leftUTF8 < 3 then
break;
c1 := byte(pch^);
Inc(pch);
c2 := byte(pch^);
Inc(pch);
word(pwc^) :=
(word(ch AND $0F) SHL 12) OR
(word(c1 AND $3F) SHL 6) OR
(c2 AND $3F);
Inc(pwc);
Dec(leftUTF8,3);
end;
end; //while
Result := integer(pwc)-integer(@unicodeBuf);
end; { UTF8BufToWideCharBuf }
function UTF8Encode(const ws: WideString): UTF8String;
begin
if ws = '' then
Result := ''
else begin
SetLength(Result, Length(ws)*3); // worst case - 3 bytes per character
SetLength(Result, WideCharBufToUTF8Buf(ws[1], Length(ws)*SizeOf(WideChar),
Result[1]));
end;
end; { UTF8Encode }
function UTF8Decode(const sUtf: UTF8String): WideString;
var
leftUtf: integer;
begin
if sUtf = '' then
Result := ''
else begin
SetLength(Result, Length(sUtf)); // worst case - 1 widechar per character
SetLength(Result, UTF8BufToWideCharBuf(sUtf[1], Length(sUtf), Result[1], leftUtf)
div SizeOf(WideChar));
end;
end; { UTF8Decode }
{$ENDIF NeedUTF}
{ Handles }
{:Closes handle (if it is not already INVALID_HANDLE_VALUE) and sets it to
INVALID_HANDLE_VALUE.
@author gabr
@since 2002-11-25
}
procedure DSiCloseHandleAndInvalidate(var handle: THandle);
begin
if handle <> INVALID_HANDLE_VALUE then begin
CloseHandle(handle);
handle := INVALID_HANDLE_VALUE;
end;
end; { DSiCloseHandleAndInvalidate }
{:Closes handle (if it is not already 0) and sets it to 0.
@author gabr
@since 2002-11-25
}
procedure DSiCloseHandleAndNull(var handle: THandle);
begin
if handle <> 0 then begin
CloseHandle(handle);
handle := 0;
end;
end; { DSiCloseHandleAndNull }
{:Shortcut for WaitForMultipleObjects with two objects.
@author gabr
@since 2002-11-25
}
function DSiWaitForTwoObjects(obj0, obj1: THandle; waitAll: boolean;
timeout: DWORD): DWORD;
var
handles: array [0..1] of THandle;
begin
handles[0] := obj0;
handles[1] := obj1;
Result := WaitForMultipleObjects(2, @handles, waitAll, timeout);
end; { DSiWaitForTwoObjects }
{:Shortcut for WaitForMultipleObjectsEx with two objects.
@author gabr
@since 2002-11-25
}
function DSiWaitForTwoObjectsEx(obj0, obj1: THandle; waitAll: boolean;
timeout: DWORD; alertable: boolean): DWORD;
var
handles: array [0..1] of THandle;
begin
handles[0] := obj0;
handles[1] := obj1;
Result := WaitForMultipleObjectsEx(2, @handles, waitAll, timeout, alertable);
end; { DSiWaitForTwoObjectsEx }
{:As Win32Check, only used for file handles.
@author gabr
@since 2003-11-12
}
function DSiWin32CheckHandle(handle: THandle): THandle;
begin
Win32Check(handle <> INVALID_HANDLE_VALUE);
Result := handle;
end; { TDSiRegistry.DSiWin32CheckHandle }
{:As Win32Check, only used for various handles.
@author gabr
@since 2005-07-11
}
function DSiWin32CheckNullHandle(handle: THandle): THandle;
begin
Win32Check(handle <> 0);
Result := handle;
end; { TDSiRegistry.DSiWin32CheckNullHandle }
{:Shortcut for MsgWaitForMultipleObjects with two objects.
@author gabr
@since 2002-11-25
}
function DSiMsgWaitForTwoObjectsEx(obj0, obj1: THandle; timeout: DWORD;
wakeMask: DWORD; flags: DWORD): DWORD;
var
handles: array [0..1] of THandle;
begin
handles[0] := obj0;
handles[1] := obj1;
Result := MsgWaitForMultipleObjectsEx(2, handles, timeout, wakeMask, flags);
end; { DSiWaitForThreeObjects }
{:Shortcut for WaitForMultipleObjects with three objects.
@author gabr
@since 2002-11-25
}
function DSiWaitForThreeObjects(obj0, obj1, obj2: THandle; waitAll: boolean;
timeout: DWORD): DWORD;
var
handles: array [0..2] of THandle;
begin
handles[0] := obj0;
handles[1] := obj1;
handles[2] := obj2;
Result := WaitForMultipleObjects(3, @handles, waitAll, timeout);
end; { DSiWaitForThreeObjects }
{:Shortcut for WaitForMultipleObjectsEx with three objects.
@author gabr
@since 2002-11-25
}
function DSiWaitForThreeObjectsEx(obj0, obj1, obj2: THandle; waitAll: boolean;
timeout: DWORD; alertable: boolean): DWORD;
var
handles: array [0..2] of THandle;
begin
handles[0] := obj0;
handles[1] := obj1;
handles[2] := obj2;
Result := WaitForMultipleObjectsEx(3, @handles, waitAll, timeout, alertable);
end; { DSiWaitForThreeObjectsEx }
{:Shortcut for MsgWaitForMultipleObjectsEx with three objects.
@author gabr
@since 2002-11-25
}
function DSiMsgWaitForThreeObjectsEx(obj0, obj1, obj2: THandle;
timeout: DWORD; wakeMask: DWORD; flags: DWORD): DWORD;
var
handles: array [0..2] of THandle;
begin
handles[0] := obj0;
handles[1] := obj1;
handles[2] := obj2;
Result := MsgWaitForMultipleObjectsEx(3, handles, timeout, wakeMask, flags);
end; { DSiWaitForThreeObjectsEx }
{ Registry }
{:Reads binary from the registry returning default value if name doesn't exist in the
open key. Includes special handling for integer and string keys.
@author Lee_Nover
@since 2004-11-29
}
function TDSiRegistry.ReadBinary(const name, defval: string): string;
begin
try
if GetDataSize(name) < 0 then
Abort; // D4 does not generate an exception!
case GetDataType(name) of
rdInteger:
Result := IntToStr(inherited ReadInteger(name));
rdBinary:
begin
SetLength(Result, GetDataSize(name));
SetLength(Result, ReadBinaryData(name, Pointer(Result)^, Length(Result)));
end; //rdBinary
else
Result := inherited ReadString(name);
end;
except ReadBinary := defval; end;
end; { TDSiRegistry.ReadBinary }
{:Reads binary from the registry. Overwrites 'dataStream'. Keeps data stream unchanged
if value is not found in the registry.
Includes special handling for integer and string keys.
@author gabr
@returns True if value exists in the registry.
@since 2005-02-13
}
function TDSiRegistry.ReadBinary(const name: string; dataStream: TStream): boolean;
var
i: integer;
s: string;
begin
try
if GetDataSize(name) < 0 then
Abort; // D4 does not generate an exception!
dataStream.Size := 0;
case GetDataType(name) of
rdInteger:
begin
i := ReadInteger(name, 0);
dataStream.Write(i, SizeOf(i));
end; //rdInteger
rdBinary:
begin
if dataStream is TMemoryStream then begin
dataStream.Size := GetDataSize(name);
dataStream.Position := 0;
ReadBinaryData(name, TMemoryStream(dataStream).Memory^, dataStream.Size);
end
else begin
s := ReadBinary(name, '');
if s <> '' then
dataStream.Write(s[1], Length(s));
end;
end; //rdBinary
else
begin
s := ReadString(name, '');
if s <> '' then
dataStream.Write(s[1], Length(s));
end; //else
end; //case
Result := true;
except Result := false; end;
end; { TDSiRegistry.ReadBinary }
{:Reads boolean value from the registry returning default value if name doesn't exist in
the open key.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadBool(const name: string; defval: boolean): boolean;
begin
try
if GetDataSize(name) < 0 then
Abort; // D4 does not generate an exception!
ReadBool := inherited ReadBool(name);
except ReadBool := defval; end;
end; { TDSiRegistry.ReadBool }
{:Reads date-time from the registry returning default value if name doesn't
exist in the open key.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadDate(const name: string; defval: TDateTime): TDateTime;
begin
try
if GetDataSize(name) < 0 then
Abort; // D4 does not generate an exception!
ReadDate := inherited ReadDate(name);
except ReadDate := defval; end;
end; { TDSiRegistry.ReadDate }
{:Reads TFont from the registry.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadFont(const name: string; font: TFont): boolean;
var
istyle: integer;
fstyle: TFontStyles;
begin
Result := false;
if GetDataSize(name) > 0 then begin
font.Charset := ReadInteger(name+'_charset', font.Charset);
font.Color := ReadInteger(name+'_color', font.Color);
font.Height := ReadInteger(name+'_height', font.Height);
font.Name := ReadString(name, font.Name);
font.Pitch := TFontPitch(ReadInteger(name+'_pitch', Ord(font.Pitch)));
font.Size := ReadInteger(name+'_size', font.Size);
fstyle := font.Style;
istyle := 0;
Move(fstyle, istyle, SizeOf(TFontStyles));
istyle := ReadInteger(name+'_style', istyle);
Move(istyle, fstyle, SizeOf(TFontStyles));
font.Style := fstyle;
Result := true;
end;
end; { TDSiRegistry.ReadFont }
{:Reads integer from the registry returning default value if name doesn't
exist in the open key.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadInteger(const name: string; defval: integer): integer;
begin
try
if GetDataSize(name) < 0 then
Abort; // D4 does not generate an exception!
if GetDataType(name) = rdInteger then
Result := inherited ReadInteger(name)
else if (GetDataType(name) = rdBinary) and (GetDataSize(name) = SizeOf(Result)) then
ReadBinaryData(name, Result, SizeOf(Result))
else
Result := StrToIntDef(ReadString(name, IntToStr(defval)), defval);
except ReadInteger := defval; end;
end; { TDSiRegistry.ReadInteger }
{:Reads 64-bit integer from the registry returning default value if name
doesn't exist in the open key.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadInt64(const name: string; defval: int64): int64;
begin
Result := StrToInt64Def(ReadString(name, '!'), defval);
end; { TDSiRegistry.ReadInt64 }
{:Reads string from the registry returning default value if name doesn't exist
in the open key.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadString(const name, defval: string): string;
begin
Result := defval;
try
if GetDataSize(name) < 0 then
Exit;
if GetDataType(name) = rdInteger then
Result := IntToStr(inherited ReadInteger(name))
else
Result := inherited ReadString(name);
except Result := defval; end;
end; { TDSiRegistry.ReadString }
{:Writes a MULTI_SZ value into the TStrings object.
@author Colin Wilson, borland.public.delphi.vcl.components.using
@since 2003-10-02
}
procedure TDSiRegistry.ReadStrings(const name: string; strings: TStrings);
var
buffer : PChar;
p : PChar;
valueLen : DWORD;
valueType: DWORD;
begin
strings.Clear;
SetLastError(RegQueryValueEx(CurrentKey, PChar(name), nil, @valueType, nil,
@valueLen));
if GetLastError <> ERROR_SUCCESS then
raise ERegistryException.CreateFmt('Unable read MULTI_SZ value. %s',
[SysErrorMessage(GetLastError)])
else if valueType <> REG_MULTI_SZ then
raise ERegistryException.Create('String list expected.')
else begin
GetMem(buffer, valueLen);
try
RegQueryValueEx(CurrentKey, PChar(name), nil, nil, PByte(buffer),
@valueLen);
p := buffer;
while p^ <> #0 do begin
strings.Add(p);
Inc (p, LStrLen(p) + 1);
end
finally FreeMem(buffer); end
end;
end; { TDSiRegistry.ReadStrings }
{:Reads variant (string, integer, boolean, or date-time) from the registry
returning default value if name doesn't exist in the open key.
@author gabr
@since 2002-11-25
}
function TDSiRegistry.ReadVariant(const name: string; defval: variant): variant;
begin
case VarType(defval) of
varInteger: Result := ReadInteger(name,defval);
varBoolean: Result := ReadBool(name,defval);
varString : Result := ReadString(name,defval);
{$IFDEF Unicode}
varOleStr : Result := ReadString(name, defval);
{$ELSE}
varOleStr : Result := UTF8Decode(ReadString(name, UTF8Encode(defval)));
{$ENDIF Unicode}
varDate : Result := ReadDate(name,defval);
else raise Exception.Create('TDSiRegistry.ReadVariant: Invalid value type!');
end;
end; { TDSiRegistry.ReadVariant }
{:Writes string as binary into the registry.
@author Lee_Nover
@since 2004-11-29
}
procedure TDSiRegistry.WriteBinary(const name, data: string);
begin
WriteBinaryData(name, pointer(data)^, Length(data));
end; { TDSiRegistry.WriteBinary }
{:Writes stream into binary registry entry.
@author gabr
@since 2005-02-13
}
procedure TDSiRegistry.WriteBinary(const name: string; data: TStream);
var
ms: TMemoryStream;
begin
if data is TMemoryStream then
WriteBinaryData(name, TMemoryStream(data).Memory^, data.Size)
else begin
ms := TMemoryStream.Create;
try
ms.CopyFrom(data, 0);
WriteBinaryData(name, ms.Memory^, ms.Size);
finally FreeAndNil(ms); end;
end;
end; { TDSiRegistry.WriteBinary }
{:Writes 64-bit integer into the registry.
@author gabr
@since 2002-11-25
}
procedure TDSiRegistry.WriteInt64(const name: string; value: int64);
begin
WriteString(name, IntToStr(value));
end; { TDSiRegistry.WriteInt64 }
{:Writes variant (string, integer, boolean, or date-time) into the registry.
@author gabr
@since 2002-11-25
}
procedure TDSiRegistry.WriteVariant(const name: string; value: variant);
begin
case VarType(value) of
varInteger: WriteInteger(name,value);
varBoolean: WriteBool(name,value);
varString : WriteString(name,value);
{$IFDEF Unicode}
varOleStr : WriteString(name, value);
{$ELSE}
varOleStr : WriteString(name,UTF8Encode(value));
{$ENDIF Unicode}
varDate : WriteDate(name,value);
else raise Exception.Create('TDSiRegistry.WriteVariant: Invalid value type!');
end;
end; { TDSiRegistry.WriteVariant }
{:Writes TFont into the registry.
@author gabr
@since 2002-11-25
}
procedure TDSiRegistry.WriteFont(const name: string; font: TFont);
var
istyle: integer;
fstyle: TFontStyles;
begin
WriteInteger(name+'_charset', font.Charset);
WriteInteger(name+'_color', font.Color);
WriteInteger(name+'_height', font.Height);
WriteString(name, font.Name);
WriteInteger(name+'_pitch', Ord(font.Pitch));
WriteInteger(name+'_size', font.Size);
fstyle := font.Style;
istyle := 0;
Move(fstyle, istyle, SizeOf(TFontStyles));
WriteInteger(name+'_style', istyle);
end; { TDSiRegistry.WriteFont }
{:Writes TStrings into a MULTI_SZ value.
@author Colin Wilson, borland.public.delphi.vcl.components.using
@since 2003-10-02
}
procedure TDSiRegistry.WriteStrings(const name: string; strings: TStrings);
var
buffer: PChar;
i : integer;
p : PChar;
size : DWORD;
begin
size := 0;
for i := 0 to strings.Count - 1 do
Inc(size, Length(strings[i]) + 1);
Inc (size);
GetMem (buffer, size);
try
p := buffer;
for i := 0 to strings.count - 1 do begin
LStrCpy(p, PChar(strings[i]));
Inc(p, LStrLen(p) + 1);
end;
p^ := #0;
SetLastError(RegSetValueEx(CurrentKey, PChar(name), 0, REG_MULTI_SZ,
buffer, size));
if GetLastError <> ERROR_SUCCESS then
raise ERegistryException.CreateFmt('Unable to write MULTI_SZ value. %s',
[SysErrorMessage(GetLastError)]);
finally FreeMem(buffer); end
end; { TDSiRegistry.WriteStrings }
{:Creates a key in the registry.
@author gabr
@since 2002-11-25
}
function DSiCreateRegistryKey(const registryKey: string; root: HKEY): boolean;
begin
Result := false;
with TRegistry.Create do try
RootKey := root;
if OpenKey(registryKey, true) then begin
CloseKey;
Result := true;
end;
finally {TRegistry.}Free; end;
end; { DSiCreateRegistryKey }
{:Deletes a key with all subkeys from the registry.
@author gabr
@since 2002-11-25
}
function DSiKillRegistry(const registryKey: string; root: HKEY): boolean;
begin
with TRegistry.Create do try
RootKey := root;
Result := DeleteKey(registryKey);
finally {TRegistry.} Free; end;
end; { DSiKillRegistry }
{:Reads 64-bit integer from the registry, returning default value if the
specified name doesn't exist in the registry.
@author gabr
@since 2002-11-25
}
function DSiReadRegistry(const registryKey, name: string; defaultValue: int64;
root: HKEY; access: longword): int64;
begin
Result := defaultValue;
try
with TDSiRegistry.Create(access) do try
RootKey := root;
if OpenKeyReadOnly(registryKey) then try
Result := ReadInt64(name, defaultValue);
finally CloseKey; end;
finally {TDSiRegistry.}Free; end;
except end;
end; { DSiReadRegistry }
{:Reads variant (string, integer, boolean, or date-time) from the registry,
returning default value if the specified name doesn't exist in the registry.
@author gabr
@since 2002-11-25
}
function DSiReadRegistry(const registryKey, name: string; defaultValue: Variant;
root: HKEY; access: longword): Variant;
begin
Result := defaultValue;
try
with TDSiRegistry.Create(access) do try
RootKey := root;
if OpenKeyReadOnly(registryKey) then try
Result := ReadVariant(name, defaultValue);
finally CloseKey; end;
finally {TDSiRegistry.}Free; end;
except end;
end; { DSiReadRegistry }
{:Checks whether the specified registry key exists.
@author gabr
@since 2002-11-25
}
function DSiRegistryKeyExists(const registryKey: string; root: HKEY;
access: longword): boolean;
begin
with TRegistry.Create(access) do try
RootKey := root;
Result := KeyExists(registryKey);
finally {TRegistry.}Free; end;
end; { DSiRegistryKeyExists }
{:Checks whether the specified registry value exists.
@author gabr
@since 2006-02-06
}
function DSiRegistryValueExists(const registryKey, name: string; root: HKEY;
access: longword): boolean;
begin
Result := false;
with TRegistry.Create(access) do try
RootKey := root;
if OpenKeyReadOnly(registryKey) then try
Result := ValueExists(name);
finally CloseKey; end;
finally {TRegistry.}Free; end;
end; { DSiRegistryKeyExists }
{:Writes 64-bit integer into the registry.
@author gabr
@since 2002-11-25
}
function DSiWriteRegistry(const registryKey, name: string; value: int64;
root: HKEY): boolean;
begin
Result := false;
try
with TDSiRegistry.Create do try
RootKey := root;
if OpenKey(registryKey, true) then try
WriteInt64(name, value);
Result := true;
finally CloseKey; end;
finally {TDSiRegistry.}Free; end;
except end;
end; { DSiWriteRegistry }
{:Writes variant (string, integer, boolean, or date-time) into the registry.
@author gabr
@since 2002-11-25
}
function DSiWriteRegistry(const registryKey, name: string; value: Variant;
root: HKEY): boolean;
begin
Result := false;
try
with TDSiRegistry.Create do try
RootKey := root;
if OpenKey(registryKey, true) then try
WriteVariant(name, value);
Result := true;
finally CloseKey; end;
finally {TDSiRegistry.}Free; end;
except end;
end; { DSiWriteRegistry }
{ Files }
{:Checks if application can write to a folder.
@author gabr
@since 2005-12-08
}
function DSiCanWriteToFolder(const folderName: string): boolean;
var
tempFile: string;
begin
Result := false;
if DirectoryExists(folderName) then begin
tempFile := DSiGetTempFileName('dsi', folderName);
if tempFile <> '' then begin
DSiKillFile(tempFile);
Result := true;
end;
end;
end; { DSiCanWriteToFolder }
{:Internal. Sets specified compression flag.
@since 2006-08-14
}
function DSiSetCompression(fileHandle: THandle; compressionFormat: integer): boolean;
var
comp: SHORT;
res : DWORD;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then //only NT can compress files
Result := true
else begin
res := 0;
comp := compressionFormat;
Result := DeviceIoControl(fileHandle, FSCTL_SET_COMPRESSION, @comp, SizeOf(SHORT),
nil, 0, res, nil);
end;
end; { DSiSetCompression }
{:Compresses file on NTFS filesystem.
@author gabr
@since 2006-08-14
}
function DSiCompressFile(fileHandle: THandle): boolean;
begin
Result := DSiSetCompression(fileHandle, COMPRESSION_FORMAT_DEFAULT);
end; { DSiCompressFile }
{:Connects to a network resource and optionally maps drive letter to it.
@author gabr
@since 2008-05-05
}
function DSiConnectToNetworkResource(const networkResource: string; const mappedLetter:
string = ''; const username: string = ''; const password: string = ''): boolean;
var
bufferSize : DWORD;
driveName : string;
netResource: TNetResource;
remoteName : pointer;
wnetResult : integer;
begin
Result := false;
if mappedLetter <> '' then begin
GetMem(remoteName, MAX_PATH+1);
try
driveName := mappedLetter[1] + ':';
wnetResult := GetDriveType(PChar(driveName + '\'));
if wnetResult = DRIVE_REMOTE then begin
bufferSize := MAX_PATH;
wnetResult := WNetGetConnection(PChar(driveName), remoteName, bufferSize);
if wnetResult = ERROR_MORE_DATA then begin
FreeMem(remoteName);
GetMem(remoteName, bufferSize);
wnetResult := WNetGetConnection(PChar(driveName), remoteName, bufferSize);
end;
Result := (wnetResult = NO_ERROR) and (AnsiSameText(networkResource, Trim(PChar(remoteName))));
if (not Result) and (wnetResult = NO_ERROR) then
WNetCancelConnection2(PChar(driveName), 0, true);
end;
finally FreeMem(remoteName); end;
end;
if not Result then begin
FillChar(netResource, SizeOf (netResource), 0);
netResource.dwScope := RESOURCE_GLOBALNET;
netResource.dwType := RESOURCETYPE_DISK;
netResource.dwDisplayType := RESOURCEDISPLAYTYPE_SHARE;
netResource.dwUsage := RESOURCEUSAGE_CONNECTABLE;
if mappedLetter <> '' then
netResource.lpLocalName := PChar(driveName);
netResource.lpRemoteName := PChar(networkResource);
Result := (WNetAddConnection2(netResource, PChar(password), PChar(username), 0) = NO_ERROR);
end;
end; { DSiConnectToNetworkResource }
{:Copies a file via ShFileOperation (with animated icon etc).
@author gabr
@since 2008-05-30
}
function DSiCopyFileAnimated(ownerWindowHandle: THandle; sourceFile, destinationFile:
string; var aborted: boolean; flags: TShFileOpFlags): boolean;
var
fileOp: TSHFileOpStruct;
flag : TShFileOpFlag;
begin
FillChar(fileOp, SizeOf(fileOp), 0);
fileOp.Wnd := ownerWindowHandle;
fileOp.wFunc := FO_COPY;
sourceFile := sourceFile + #0#0;
fileOp.pFrom := PChar(sourceFile);
destinationFile := destinationFile + #0#0;
fileOp.pTo := PChar(destinationFile);
fileOp.fFlags := 0;
for flag := Low(TShFileOpFlag) to High(TShFileOpFlag) do
if flag in flags then
fileOp.fFlags := fileOp.fFlags OR CShFileOpFlagMappings[flag];
Result := (SHFileOperation(fileOp) = 0);
aborted := fileOp.fAnyOperationsAborted;
end; { DSiCopyFileAnimated }
{:Creates folder with the unique name under the temporary folder.
@author Miha-R
@since 2002-11-25
}
function DSiCreateTempFolder: string;
var
GUID: TGUID;
begin
OleCheck(CoCreateGUID(GUID));
Result := DSiGetTempPath + GUIDToString(GUID);
ForceDirectories(Result);
end; { DSiCreateTempFolder }
{:Deletes files matching file mask.
@author gabr
@since 2002-12-19
}
procedure DSiDeleteFiles(const folder, fileMask: string);
var
err : integer;
folderBk: string;
S : TSearchRec;
begin
folderBk := IncludeTrailingBackslash(folder);
err := FindFirst(folderBk+fileMask, 0, S);
if err = 0 then begin
repeat
DSiKillFile(folderBk+S.Name);
err := FindNext(S);
until err <> 0;
FindClose(S);
end;
end; { DSiDeleteFiles }
{gp}
function DSiDeleteOnReboot(const fileName: string): boolean;
begin
Result := DSiMoveOnReboot(fileName, '');
end; { DSiDeleteOnReboot }
{gp}
procedure DSiDeleteTree(const folder: string; removeSubdirsOnly: boolean);
procedure DeleteTree(const folder: string; depth: integer; delete0: boolean);
var
err: integer;
s : TSearchRec;
begin
err := FindFirst(IncludeTrailingBackslash(folder)+'*.*',faDirectory,S);
if err = 0 then begin
repeat
if (S.Attr and faDirectory) <> 0 then
if (S.Name <> '.') and (S.Name <> '..') then
DeleteTree(IncludeTrailingBackslash(folder)+S.Name, depth+1, delete0);
err := FindNext(S);
until err <> 0;
FindClose(S);
end;
if (depth > 0) or delete0 then
DSiRemoveFolder(folder);
end; { DeleteTree }
begin { DSiDeleteTree }
DeleteTree(folder, 0, not removeSubdirsOnly);
end; { DSiDeleteTree }
{gp}
function DSiDeleteWithBatch(const fileName: string; rmDir: boolean): boolean;
// Idea stollen from the article by Jeffrey Richter, first published in
// Microsoft Systems Journal, reprinted in Microsoft Developer Network.
// Simple but effective solution: create batch file that deletes exe and then
// deletes itself, then run it as an invisible console app with low priority.
var
bat : text;
tmpFile: string;
si : TStartupInfo;
pi : TProcessInformation;
begin
Result := false;
try
tmpFile := ChangeFileExt(DSiGetTempFileName('wt'),'.bat');
if tmpFile <> '' then begin
Assign(bat,tmpFile);
Rewrite(bat);
Writeln(bat,':repeat');
Writeln(bat,'del "',fileName,'"');
Writeln(bat,'if exist "',fileName,'" goto repeat');
if rmDir
then Writeln(bat,'rmdir "',ExtractFilePath(fileName),'"');
Writeln(bat,'del ',tmpFile);
Close(bat);
FillChar(si,SizeOf(si),0);
si.cb := SizeOf(si);
si.dwFlags := STARTF_USESHOWWINDOW;
si.wShowWindow := SW_HIDE;
if (CreateProcess(nil, PChar(tmpFile), nil, nil, false,
CREATE_SUSPENDED or IDLE_PRIORITY_CLASS, nil,
PChar(ExtractFilePath(tmpFile)), si, pi))
then begin
SetThreadPriority(pi.hThread, THREAD_PRIORITY_IDLE);
CloseHandle(pi.hProcess);
ResumeThread(pi.hThread);
CloseHandle(pi.hThread);
Result := true;
end;
end;
except end;
end; { DSiDeleteWithBatch }
{:Wide version of SysUtils.DirectoryExists.
@author gabr
@since 2006-08-14
}
function DSiDirectoryExistsW(const directory: WideString): boolean;
var
code: integer;
begin
code := GetFileAttributesW(PWideChar(directory));
Result := (code <> -1) and ((FILE_ATTRIBUTE_DIRECTORY AND code) <> 0);
end; { DSiDirectoryExistsW }
{gp}
function DSiEjectMedia(deviceLetter: char): boolean;
var
cd : THandle;
ret: DWORD;
begin
Result := false;
cd := CreateFile(PChar('\\.\'+deviceLetter+':'), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
if cd <> INVALID_HANDLE_VALUE then begin
Result := DeviceIoControl(cd, IOCTL_STORAGE_EJECT_MEDIA, nil, 0, nil, 0, ret, nil);
CloseHandle(cd);
end;
end; { DSiLoadMedia }
{:Deletes all files in the folder.
@author gabr
@since 2002-12-19
}
procedure DSiEmptyFolder(const folder: string);
begin
DSiDeleteFiles(folder, '*.*');
end; { DSiEmptyFolder }
{:Empties recycle bin.
@author ales
@since 2002-12-19
}
function DSiEmptyRecycleBin: boolean;
begin
Result := DSiSHEmptyRecycleBin(0, nil,
SHERB_NOCONFIRMATION OR SHERB_NOPROGRESSUI OR SHERB_NOSOUND) = S_OK;
end; { DSiEmptyRecycleBin }
{:Enumerates all files matching given mask and attribute and calls callback method for
each file.
@returns Number of files enumerated.
@author gabr
@since 2003-06-17
}
function DSiEnumFiles(const fileMask: string; attr: integer;
enumCallback: TDSiEnumFilesCallback): integer;
var
err : integer;
folder: string;
S : TSearchRec;
begin
Result := 0;
folder := IncludeTrailingBackslash(ExtractFilePath(fileMask));
err := FindFirst(fileMask, attr, S);
if err = 0 then try
repeat
enumCallback(folder+S.Name);
Inc(Result);
err := FindNext(S);
until err <> 0;
finally FindClose(S); end;
end; { DSiEnumFiles }
procedure _DSiEnumFilesEx(const folder, fileMask: string; attr: integer; enumSubfolders:
boolean; enumCallback: TDSiEnumFilesExCallback; var totalFiles: integer; var stopEnum:
boolean; fileList: TStrings; storeFullPath: boolean; currentDepth, maxDepth: integer);
var
err: integer;
s : TSearchRec;
begin
if enumSubfolders and ((maxDepth <= 0) or (currentDepth < maxDepth)) then begin
err := FindFirst(folder+'*.*',faDirectory,S);
if err = 0 then try
repeat
if (S.Attr and faDirectory) <> 0 then
if (S.Name <> '.') and (S.Name <> '..') then begin
if assigned(enumCallback) then begin
enumCallback(folder, S, true, stopEnum);
if stopEnum then
Exit;
end;
if assigned(fileList) then
if storeFullPath then
fileList.Add(folder + S.Name + '\')
else
fileList.Add(S.Name + '\');
_DSiEnumFilesEx(folder+S.Name+'\', fileMask, attr, enumSubfolders,
enumCallback, totalFiles, stopEnum, fileList, storeFullPath,
currentDepth + 1, maxDepth);
end;
err := FindNext(S);
until (err <> 0) or stopEnum;
finally FindClose(S); end;
end;
if stopEnum then
Exit;
err := FindFirst(folder+fileMask, attr, S);
if err = 0 then try
repeat
if assigned(enumCallback) then
enumCallback(folder, S, false, stopEnum);
if assigned(fileList) then
if storeFullPath then
fileList.Add(folder + S.Name)
else
fileList.Add(S.Name);
Inc(totalFiles);
err := FindNext(S);
until (err <> 0) or stopEnum;
finally FindClose(S); end;
end; { _DSiEnumFilesEx }
{:Enumerates all files matching given mask and attribute and calls callback
method for each file. Optionally descends into subfolders.
@returns Number of files (not folders!) enumerated.
@author gabr
@since 2003-06-17
}
function DSiEnumFilesEx(const fileMask: string; attr: integer; enumSubfolders: boolean;
enumCallback: TDSiEnumFilesExCallback; maxEnumDepth: integer): integer;
var
folder : string;
mask : string;
stopEnum: boolean;
begin
mask := fileMask;
folder := ExtractFilePath(mask);
Delete(mask, 1, Length(folder));
if folder <> '' then
folder := IncludeTrailingBackslash(folder);
Result := 0;
stopEnum := false;
_DSiEnumFilesEx(folder, mask, attr, enumSubfolders, enumCallback, Result, stopEnum,
nil, false, 1, maxEnumDepth);
end; { DSiEnumFilesEx }
{:Enumerates files (optionally in subfolders) and stores results into caller-provided
TStrings object.
@since 2006-05-14
}
procedure DSiEnumFilesToSL(const fileMask: string; attr: integer; fileList: TStrings;
storeFullPath: boolean; enumSubfolders: boolean; maxEnumDepth: integer);
var
folder : string;
mask : string;
stopEnum : boolean;
totalFiles: integer;
begin
fileList.Clear;
mask := fileMask;
folder := ExtractFilePath(mask);
Delete(mask, 1, Length(folder));
if folder <> '' then
folder := IncludeTrailingBackslash(folder);
stopEnum := false;
_DSiEnumFilesEx(folder, mask, attr, enumSubfolders, nil, totalFiles, stopEnum,
fileList, storeFullPath, 1, maxEnumDepth);
end; { DSiEnumFilesToSL }
{:Wide version of SysUtils.FileExists.
@author gabr
@since 2006-08-14
}
function DSiFileExistsW(const fileName: WideString): boolean;
var
code: integer;
begin
code := GetFileAttributesW(PWideChar(fileName));
Result := (code <> -1) and ((FILE_ATTRIBUTE_DIRECTORY AND code) = 0);
end; { DSiFileExistsW }
{:Checks if fileName extension is equal to the extension parameter.
Extension can be provided with or without leading period.
@author gabr
@since 2007-06-08
}
function DSiFileExtensionIs(const fileName, extension: string): boolean; overload;
var
fExt: string;
begin
fExt := ExtractFileExt(fileName);
if (Length(extension) = 0) or (extension[1] <> '.') then
Delete(fExt, 1, 1);
Result := SameText(fExt, extension);
end; { DSiFileExtensionIs }
{:Checks if fileName extension is equal to any of the extensions listed in the extension
array.
@author gabr
@since 2007-06-08
}
function DSiFileExtensionIs(const fileName: string; extension: array of string):
boolean; overload;
var
iExt: integer;
begin
Result := true;
for iExt := Low(extension) to High(extension) do
if DSiFileExtensionIs(fileName, extension[iExt]) then
Exit;
Result := false;
end; { DSiFileExtensionIs }
{:Retrieves file size.
@returns -1 for unexisting/unaccessible file or file size.
@author gabr
@since 2003-06-17
}
function DSiFileSize(const fileName: string): int64;
var
fHandle: DWORD;
begin
fHandle := CreateFile(PChar(fileName), 0, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if fHandle = INVALID_HANDLE_VALUE then
Result := -1
else try
Int64Rec(Result).Lo := GetFileSize(fHandle, @Int64Rec(Result).Hi);
finally CloseHandle(fHandle); end;
end; { DSiFileSize }
{:Wide version of DSiFileSize.
@returns -1 for unexisting/unaccessible file or file size.
@author gabr
@since 2006-08-14
}
function DSiFileSizeW(const fileName: WideString): int64;
var
fHandle: DWORD;
begin
fHandle := CreateFileW(PWideChar(fileName), 0, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if fHandle = INVALID_HANDLE_VALUE then
Result := -1
else try
Int64Rec(Result).Lo := GetFileSize(fHandle, @Int64Rec(Result).Hi);
finally CloseHandle(fHandle); end;
end; { DSiFileSizeW }
{:Calculates size of all files in a specified folder.
@author radicalb, gabr
@since 2007-05-30
}
function DSiGetFolderSize(const folder: string; includeSubfolders: boolean): int64;
var
err : integer;
folderBk: string;
rec : TSearchRec;
begin
Result := 0;
folderBk := IncludeTrailingBackslash(folder);
err := FindFirst(folderBk + '*.*', faAnyFile, rec);
if err = 0 then try
repeat
Inc(Result, rec.Size);
if includeSubfolders and ((rec.Attr and faDirectory) > 0) and
(rec.Name <> '.') and (rec.Name <> '..')
then
Inc(Result, DSiGetFolderSize(folderBk + rec.Name, true));
err := FindNext(rec);
until (err <> 0);
finally FindClose(rec); end;
end; { DSiGetFolderSize }
{:Returns one of the file times - creation time, last access time, last write time.
Returns 0 if file cannot be accessed.
@author Lee_Nover
@since 2006-03-01
}
function DSiGetFileTime(const fileName: string; whatTime: TDSiFileTime): TDateTime;
var
creationTime : TDateTime;
lastAccessTime : TDateTime;
lastModificationTime: TDateTime;
begin
if not DSiGetFileTimes(fileName, creationTime, lastAccessTime, lastModificationTime) then
Result := 0
else case whatTime of
ftCreation: Result := creationTime;
ftLastAccess: Result := lastAccessTime;
ftLastModification: Result := lastModificationTime;
else raise Exception.Create('DSiGetFileTime: Invalid time selector');
end;
end; { DSiGetFileTime }
{:Returns file creation, last access and last write time.
@author gabr
@since 2006-12-20
}
function DSiGetFileTimes(const fileName: string; var creationTime, lastAccessTime,
lastModificationTime: TDateTime): boolean;
var
fileHandle : cardinal;
fsCreationTime : TFileTime;
fsLastAccessTime : TFileTime;
fsLastModificationTime: TFileTime;
begin
Result := false;
fileHandle := CreateFile(PChar(fileName), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, 0, 0);
if fileHandle <> INVALID_HANDLE_VALUE then try
Result :=
GetFileTime(fileHandle, @fsCreationTime, @fsLastAccessTime,
@fsLastModificationTime) and
DSiFileTimeToDateTime(fsCreationTime, creationTime) and
DSiFileTimeToDateTime(fsLastAccessTime, lastAccessTime) and
DSiFileTimeToDateTime(fsLastModificationTime, lastModificationTime);
finally
CloseHandle(fileHandle);
end;
end; { DSiGetFileTimes }
{:Returns the long pathname representation.
@author Lee_Nover
@since 2006-03-01
}
function DSiGetLongPathName(const fileName: string): string;
begin
if not assigned(GGetLongPathName) then
GGetLongPathName := DSiGetProcAddress('kernel32.dll', 'GetLongPathNameA');
if assigned(GGetLongPathName) then begin
SetLength(Result, MAX_PATH);
SetLength(Result, GGetLongPathName(PChar(fileName), PChar(Result), Length(Result)));
end
else begin
Result := '';
SetLastError(ERROR_NOT_SUPPORTED);
end;
end; { DSiGetLongPathName }
{:Returns temporary file name, either in the specified path or in the default temp path
(if 'tempPath' is empty).
@author Miha-R
@since 2002-11-25
}
function DSiGetTempFileName(const prefix, tempPath: string): string;
var
tempFileName: PChar;
useTempPath : string;
begin
Result := '';
GetMem(tempFileName, MAX_PATH * SizeOf(char));
try
if tempPath = '' then
useTempPath := DSiGetTempPath
else
useTempPath := tempPath;
if GetTempFileName(PChar(useTempPath), PChar(prefix), 0, tempFileName) <> 0 then
Result := StrPas(tempFileName)
else
Result := '';
finally FreeMem(tempFileName); end;
end; { DSiGetTempFileName }
{:Returns path designated for temporary files.
@author Miha-R
@since 2002-11-25
}
function DSiGetTempPath: string;
var
tempPath: PChar;
bufSize: DWORD;
begin
bufSize := GetTempPath(0, nil);
GetMem(tempPath, bufSize*SizeOf(char));
try
GetTempPath(bufSize, tempPath);
Result := StrPas(tempPath);
finally FreeMem(tempPath); end;
end; { DSiGetTempPath }
{:Returns unique file name with the specified extension.
@author Miha-R
@since 2002-11-25
}
function DSiGetUniqueFileName(const extension: string): string;
var
GUID: TGUID;
begin
OleCheck(CoCreateGUID(GUID));
Result := Copy(GUIDToString(GUID), 2, 36) + Extension;
end; { DSiGetUniqueFileName }
{:Checks if NTFS file is compressed.
@author gabr
@since 2006-08-14
}
function DSiIsFileCompressed(const fileName: string): boolean;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then //only NT can compress files
Result := false
else
Result := (GetFileAttributes(PChar(fileName)) AND FILE_ATTRIBUTE_COMPRESSED) =
FILE_ATTRIBUTE_COMPRESSED;
end; { DSiIsFileCompressed }
{:Wide version of DSiIsFileCompressed.
@author gabr
@since 2006-08-14
}
function DSiIsFileCompressedW(const fileName: WideString): boolean;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then //only NT can compress files
Result := false
else
Result := (GetFileAttributesW(PWideChar(fileName)) AND FILE_ATTRIBUTE_COMPRESSED) =
FILE_ATTRIBUTE_COMPRESSED;
end; { DSiIsFileCompressedW }
{:Deletes file, even if it is readonly.
@author gabr
@since 2002-11-25
}
function DSiKillFile(const fileName: string): boolean;
var
oldAttr: DWORD;
begin
if not FileExists(fileName) then
Result := true
else begin
oldAttr := GetFileAttributes(PChar(fileName));
SetFileAttributes(PChar(fileName), 0);
Result := DeleteFile(fileName);
if not Result then
SetFileAttributes(PChar(fileName), oldAttr);
end;
end; { DSiKillFile }
{gp}
function DSiLoadMedia(deviceLetter: char): boolean;
var
cd : THandle;
ret: DWORD;
begin
Result := false;
cd := CreateFile(PChar('\\.\'+deviceLetter+':'), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
if cd <> INVALID_HANDLE_VALUE then begin
Result := DeviceIoControl(cd, IOCTL_STORAGE_LOAD_MEDIA, nil, 0, nil, 0, ret, nil);
CloseHandle(cd);
end;
end; { DSiLoadMedia }
///Moves a file to another file, even if target exists.
///gabr
///2007-07-24
function DSiMoveFile(const srcName, destName: string; overwrite: boolean): boolean;
var
flags: DWORD;
begin
Result := false;
if DSiIsWinNT then begin
flags := MOVEFILE_COPY_ALLOWED;
if overwrite then
flags := flags OR MOVEFILE_REPLACE_EXISTING;
Result := MoveFileEx(PChar(srcName), PChar(destName), flags);
end
else begin
if overwrite and FileExists(destName) then
if not DeleteFile(destName) then
Exit;
Result := MoveFile(PChar(srcName), PChar(destName));
end;
end; { DSiMoveFile }
{gp}
function DSiMoveOnReboot(const srcName, destName: string): boolean;
var
wfile: string;
winit: text;
wline: string;
cont : TStringList;
i : integer;
found: boolean;
dest : PChar;
begin
if destName = '' then
dest := nil
else
dest := PChar(destName);
if DSiIsWinNT then
Result := MoveFileEx(PChar(srcName), dest, MOVEFILE_DELAY_UNTIL_REBOOT)
else
Result := false;
if not Result then begin
// not NT, write a Rename entry to WININIT.INI
wfile := DSiGetWindowsFolder+'\wininit.ini';
if FileOpenSafe(wfile,winit,500,120{one minute}) then begin
try
cont := TStringList.Create;
try
Reset(winit);
while not Eof(winit) do begin
Readln(winit,wline);
cont.Add(wline);
end; //while
if destName = '' then
wline := 'NUL='+srcName
else
wline := destName+'='+srcName;
found := false;
for i := 0 to cont.Count - 1 do begin
if UpperCase(cont[i]) = '[RENAME]' then begin
cont.Insert(i+1,wline);
found := true;
break;
end;
end; //for
if not found then begin
cont.Add('[Rename]');
cont.Add(wline);
end;
Rewrite(winit);
for i := 0 to cont.Count - 1 do
Writeln(winit,cont[i]);
Result := true;
finally cont.Free; end;
finally Close(winit); end;
end;
end;
end; { DSiMoveOnReboot }
{:Deletes all files and folders in the specified folder (recursively), then deletes the
folder.
@author gabr
@since 2002-12-19
}
procedure DSiRemoveFolder(const folder: string);
begin
DSiEmptyFolder(folder);
if DirectoryExists(folder) then
RemoveDir(folder);
end; { DSiRemoveFolder }
{ales}
function DSiShareFolder(const folder, shareName, comment: string): boolean;
var
ntComment : WideString;
ntFolder : WideString;
ntShareName : WideString;
paramError : integer;
shareInfo9x : SHARE_INFO_50_9x;
shareInfoNT : SHARE_INFO_2_NT;
w9xShareName: string;
begin
if folder = '' then
raise Exception.Create('DSiShareFolder: empty folder');
if shareName = '' then
raise Exception.Create('DSiShareFolder: empty share name');
if DSiIsWinNT then begin
ntFolder := folder;
ntShareName := shareName;
ntComment := comment;
with ShareInfoNT do begin
shi2_NetName := PWideChar(ntShareName);
shi2_Type := STYPE_DISKTREE;
shi2_Remark := PWideChar(ntComment);
shi2_Permissions := 0;
shi2_Max_Uses := -1;
shi2_Current_Uses := 0;
shi2_Path := PWideChar(ntFolder);
shi2_Passwd := nil;
end;
ParamError := 0;
Result := (DSiNTNetShareAdd(nil, 2, @ShareInfoNT, paramError) = 0);
end
else begin
with ShareInfo9x do begin
FillChar(shi50_NetName, 13, 0);
w9xShareName := Copy(shareName, 1, 13);
Move(w9xShareName[1], shi50_NetName[1], Length(w9xShareName));
shi50_Type := STYPE_DISKTREE;
shi50_Remark := PChar(comment);
shi50_rw_password[1] := #0;
shi50_ro_password[1] := #0;
shi50_flags := SHI50F_FULL;
shi50_Path := PChar(ANSIUpperCase(folder));
end;
Result := (DSi9xNetShareAdd(nil, 50, @ShareInfo9x, SizeOf(SHARE_INFO_50_9x)) = 0);
end;
end; { DSiShareFolder }
{:Uncompresses file on NTFS filesystem.
@author gabr
@since 2006-08-14
}
function DSiUncompressFile(fileHandle: THandle): boolean;
begin
Result := DSiSetCompression(fileHandle, COMPRESSION_FORMAT_NONE);
end; { DSiUncompressFile }
{ales}
function DSiUnShareFolder(const shareName: string): boolean;
var
ntShareName: WideString;
begin
if DSiIsWinNT then begin
ntShareName := shareName;
Result := (DSiNTNetShareDel(nil, PWideChar(ntShareName), 0) = 0);
end
else
Result := (DSi9xNetShareDel(nil, PChar(shareName), 0) = 0);
end; { DSiUnShareFolder }
{ Processes }
{:Convert affinity mask into a string representation (0..9, A..V).
@author gabr
@since 2003-11-14
}
function DSiAffinityMaskToString(affinityMask: DWORD): string;
var
idxID: integer;
begin
Result := '';
for idxID := 1 to 32 do begin
if Odd(affinityMask) then
Result := Result + DSiCPUIDs[idxID];
affinityMask := affinityMask SHR 1;
end;
end; { DSiAffinityMaskToString }
{:Enables specified privilege for the current process.
@author Gre-Gor
@since 2004-02-12
}
function DSiEnablePrivilege(const privilegeName: string): boolean;
var
hToken : DWORD;
retLength: DWORD;
tokenPriv: TTokenPrivileges;
begin
if not DSiIsWinNT then
Result := true
else begin
Result := false;
if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
Exit;
try
tokenPriv.PrivilegeCount := 1;
if not LookupPrivilegeValue(nil, PChar(privilegeName), tokenPriv.Privileges[0].Luid) then
Exit;
tokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
if not AdjustTokenPrivileges(hToken, false, tokenPriv, SizeOf(tokenPriv), nil, retLength) then
Exit;
Result := true;
finally CloseHandle(hToken); end;
end;
end; { DSiEnablePrivilege }
{:Executes an external program.
@author Miha-R
@returns MaxInt if CreateProcess fails or process exit code if wait is specified or 0
in other cases.
@since 2002-11-25
}
function DSiExecute(const commandLine: string; visibility: integer;
const workDir: string; wait: boolean): cardinal;
var
processInfo: TProcessInformation;
startupInfo: TStartupInfo;
useWorkDir : string;
begin
if workDir = '' then
GetDir(0, useWorkDir)
else
useWorkDir := workDir;
FillChar(startupInfo, SizeOf(startupInfo), #0);
startupInfo.cb := SizeOf(startupInfo);
startupInfo.dwFlags := STARTF_USESHOWWINDOW;
startupInfo.wShowWindow := visibility;
if not CreateProcess(nil, PChar(commandLine), nil, nil, false,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
PChar(useWorkDir), startupInfo, processInfo)
then
Result := MaxInt
else begin
if wait then begin
WaitForSingleObject(processInfo.hProcess, INFINITE);
GetExitCodeProcess(processInfo.hProcess, Result);
end
else
Result := 0;
CloseHandle(processInfo.hProcess);
CloseHandle(processInfo.hThread);
end;
end; { DSiExecute }
{:Executes process as another user. Same as DSiExecute on 9x architecture.
@author gabr
@returns Returns MaxInt if any Win32 API fails or process exit code if wait is
specified or 0 in other cases.
@since 2002-12-19
}
function DSiExecuteAsUser(const commandLine, username, password, domain: string;
visibility: integer; const workDir: string; wait: boolean): cardinal;
var
lastError : DWORD;
logonHandle: THandle;
processInfo: TProcessInformation;
startupInfo: TStartupInfo;
useWorkDir : string;
begin
if not DSiIsWinNT then
Result := DSiExecute(commandLine, visibility, workDir, wait)
else begin
Result := MaxInt;
if DSiLogonUser(PChar(username), PChar(domain), PChar(password),
LOGON32_LOGON_INTERACTIVE, LOGON32_PROVIDER_DEFAULT, logonHandle) then
begin
if workDir = '' then
GetDir(0, useWorkDir)
else
useWorkDir := workDir;
FillChar(startupInfo, SizeOf(startupInfo), #0);
startupInfo.cb := SizeOf(startupInfo);
startupInfo.dwFlags := STARTF_USESHOWWINDOW;
startupInfo.wShowWindow := visibility;
if not DSiCreateProcessAsUser(logonHandle, nil, PChar(commandLine), nil,
nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
PChar(useWorkDir), startupInfo, processInfo)
then
Result := MaxInt
else begin
if wait then begin
WaitForSingleObject(processInfo.hProcess, INFINITE);
GetExitCodeProcess(processInfo.hProcess, Result);
end
else
Result := 0;
CloseHandle(processInfo.hProcess);
CloseHandle(processInfo.hThread);
end;
lastError := GetLastError;
CloseHandle(logonHandle);
SetLastError(lastError);
end;
end;
end; { DSiExecuteAsUser }
{:Executes console process in a hidden window and captures its output in a TStrings
object.
Totaly reworked on 2006-01-23. New code contributed by matej.
Handles only up to 1 MB of console process output.
@returns ID of the console process or 0 if process couldn't be started.
@author aoven, Lee_Nover, gabr, matej
@since 2003-05-24
}
function DSiExecuteAndCapture(const app: string; output: TStrings;
const workDir: string; var exitCode: longword): cardinal;
const
ReadBuffer = 1048576; // 1 MB Buffer
var
Security : TSecurityAttributes;
ReadPipe : THandle;
WritePipe : THandle;
start : TStartUpInfo;
ProcessInfo : TProcessInformation;
Buffer : PAnsiChar;
TotalBytesRead : DWORD;
BytesRead : DWORD;
AppRunning : integer;
n : integer;
BytesLeftThisMessage: integer;
TotalBytesAvail : integer;
useWorkDir : string;
begin
Result := 0;
Security.nLength := SizeOf(TSecurityAttributes);
Security.bInheritHandle := true;
Security.lpSecurityDescriptor := nil;
if CreatePipe (ReadPipe, WritePipe, @Security, 0) then begin
Buffer := AllocMem(ReadBuffer + 1);
FillChar(Start,Sizeof(Start),#0);
start.cb := SizeOf(start);
start.hStdOutput := WritePipe;
start.hStdInput := ReadPipe;
start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;
if workDir = '' then
GetDir(0, useWorkDir)
else
useWorkDir := workDir;
if CreateProcess(nil, PChar(app), @Security, @Security, true,
CREATE_NO_WINDOW or NORMAL_PRIORITY_CLASS, nil,PChar(useWorkDir), start,
ProcessInfo) then
begin
Result := ProcessInfo.hProcess;
n := 0;
TotalBytesRead := 0;
repeat
// Increase counter to prevent an endless loop if the process is dead
Inc(n,1);
AppRunning := WaitForSingleObject(ProcessInfo.hProcess,100);
if not PeekNamedPipe(ReadPipe, @Buffer[TotalBytesRead], ReadBuffer, @BytesRead,
@TotalBytesAvail, @BytesLeftThisMessage)
then
break //repeat
else if BytesRead > 0 then
ReadFile(ReadPipe,Buffer[TotalBytesRead],BytesRead,BytesRead,nil);
TotalBytesRead := TotalBytesRead + BytesRead;
until (AppRunning <> WAIT_TIMEOUT) or (n > 150);
Buffer[TotalBytesRead] := #0;
OemToCharA(Buffer, Buffer);
{$IFDEF Unicode}
output.Text := UnicodeString(StrPas(Buffer));
{$ELSE}
output.Text := StrPas(Buffer);
{$ENDIF Unicode}
end;
FreeMem(Buffer);
GetExitCodeProcess(ProcessInfo.hProcess, exitCode);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
CloseHandle(ReadPipe);
CloseHandle(WritePipe);
end;
end; { DSiExecuteAndCapture }
{:Retrieves affinity mask of the current process as a list of CPU IDs (0..9, A..V).
@author gabr
@since 2003-11-12
}
function DSiGetProcessAffinity: string;
begin
Result := DSiAffinityMaskToString(DSiGetProcessAffinityMask);
end; { DSiGetProcessAffinity }
{:Retrieves current process' affinity mask as a DWORD.
@author gabr
@since 2003-11-14
}
function DSiGetProcessAffinityMask: DWORD;
var
systemAffinityMask: DWORD;
begin
if not DSiIsWinNT then
Result := 1
else
GetProcessAffinityMask(GetCurrentProcess, Result, systemAffinityMask);
end; { DSiGetProcessAffinityMask }
{:Returns memory counters for the current process.
Requires Windows NT.
@author gabr
@since 2006-12-20
}
function DSiGetProcessMemory(var memoryCounters: TProcessMemoryCounters): boolean;
begin
Result := DSiGetProcessMemory(GetCurrentProcess, memoryCounters);
end; { DSiGetProcessMemory }
{:Returns memory counters for a process.
Requires Windows NT.
@author gabr
@since 2006-12-20
}
function DSiGetProcessMemory(process: THandle; var memoryCounters:
TProcessMemoryCounters): boolean;
begin
FillChar(memoryCounters, SizeOf(memoryCounters), 0);
memoryCounters.cb := SizeOf(memoryCounters);
Result := DSiGetProcessMemoryInfo(process, @memoryCounters, memoryCounters.cb);
end; { DSiGetProcessMemory }
{:Returns exe file name of a process.
Requires Windows NT.
@author gabr
@since 2007-11-07
}
function DSiGetProcessFileName(process: THandle; var processName: string): boolean;
var
count : DWORD;
fileName : array [0..MAX_PATH] of char;
mainModule: HMODULE;
begin
Result := false;
if DSiEnumProcessModules(process, @mainModule, 1, count) then begin
Result := (DSiGetModuleFileNameEx(process, mainModule, fileName, MAX_PATH) > 0);
if (not Result) and (GetLastError = ERROR_INVALID_HANDLE) then
Result := (DSiGetProcessImageFileName(process, fileName, MAX_PATH) > 0);
if Result then
processName := string(fileName);
end;
end; { DSiGetProcessFileName }
{:Returns owner (user and domain) of the specified process. Requires Toolhelp API (e.g.
non-NT4 OS).
@author Gre-Gor
@since 2004-02-12
}
function DSiGetProcessOwnerInfo(const processName: string; var user,
domain: string): boolean;
var
processID: DWORD;
begin
if not DSiGetProcessID(processName, processID) then
Result := false
else
Result := DSiGetProcessOwnerInfo(processID, user, domain);
end; { DSiGetProcessOwnerInfo }
procedure RetrieveSIDInfo(sid: PSID; var user, domain: string);
var
domainSize: DWORD;
sidUse : SID_NAME_USE;
userSize : DWORD;
begin
userSize := 257;
domainSize := 257;
SetLength(user, userSize);
SetLength(domain, domainSize);
if not LookupAccountSID(nil, sid, PChar(user), userSize, PChar(domain), domainSize, sidUse) then
if GetLastError = ERROR_NONE_MAPPED then
user := '?';
user := PChar(user);
domain := PChar(domain);
end; { RetrieveSIDInfo }
function GetOwnerName(descriptor: PSecurityDescriptor; var user,
domain: string): boolean;
var
defaulted: BOOL;
sid : PSID;
begin
Result := false;
if not GetSecurityDescriptorOwner(descriptor, sid, defaulted) then
Exit;
RetrieveSIDInfo(sid, user, domain);
Result := true;
end; { GetOwnerName }
{:Returns owner (user and domain) of the specified process.
@author Gre-Gor
@since 2004-02-12
}
function DSiGetProcessOwnerInfo(processID: DWORD; var user, domain: string): boolean;
var
descrSize : DWORD;
neededSize : DWORD;
process : THandle;
securityDescr: PSecurityDescriptor;
tmpResult : boolean;
begin
Result := false;
if not DSiEnablePrivilege('SeDebugPrivilege') then
Exit;
process := OpenProcess(PROCESS_ALL_ACCESS, false, processID);
try
descrSize := 4096;
neededSize := 0;
securityDescr := AllocMem(descrSize);
while true do begin
tmpResult := GetKernelObjectSecurity(process, OWNER_SECURITY_INFORMATION,
securityDescr, descrSize, neededSize);
if tmpResult then begin
if (neededSize > 0) and (descrSize <> neededSize) then begin
descrSize := neededSize;
ReallocMem(securityDescr, descrSize);
end
else begin
Result := GetOwnerName(securityDescr, user, domain);
break; //while
end;
end
else if GetLastError <> ERROR_INSUFFICIENT_BUFFER then begin
ReallocMem(securityDescr, 0);
break; //while
end;
end;
finally CloseHandle(process); end;
end; { TDSiRegistry.DSiGetProcessOwnerInfo}
{:Returns various times of the current process.
@author gabr
@since 2006-12-20
}
function DSiGetProcessTimes(var creationTime: TDateTime; var userTime, kernelTime:
int64): boolean;
var
exitTime: TDateTime;
begin
Result := DSiGetProcessTimes(GetCurrentProcess, creationTime, exitTime, userTime,
kernelTime);
end; { DSiGetProcessTimes }
{:Returns various times of a process.
@author gabr
@since 2006-12-20
}
function DSiGetProcessTimes(process: THandle; var creationTime, exitTime: TDateTime; var
userTime, kernelTime: int64): boolean;
var
fsCreationTime: TFileTime;
fsExitTime : TFileTime;
fsKernelTime : TFileTime;
fsUserTime : FileTime;
begin
Result :=
GetProcessTimes(process, fsCreationTime, fsExitTime, fsKernelTime, fsUserTime) and
DSiFileTimeToDateTime(fsCreationTime, creationTime) and
DSiFileTimeToDateTime(fsExitTime, exitTime);
if Result then begin
kernelTime := DSiFileTimeToMicroSeconds(fsKernelTime);
userTime := DSiFileTimeToMicroSeconds(fsUserTime);
end;
end; { DSiGetProcessTimes }
{:Retrieves ID of the specified process. Requires Toolhelp API.
@returns False if ID cannot be retrieved. Check GetLastError - if it is 0, process
doesn't exist; otherwise it contains the Win32 error code.
@author gabr
@since 2004-02-12
}
function DSiGetProcessID(const processName: string; var processID: DWORD): boolean;
var
hSnapshot: THandle;
procEntry: TProcessEntry32;
begin
Result := false;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot = 0 then
Exit;
try
procEntry.dwSize := Sizeof(procEntry);
if not Process32First(hSnapshot, procEntry) then
Exit;
repeat
if AnsiSameText(procEntry.szExeFile, processName) then begin
processID := procEntry.th32ProcessID;
Result := true;
break; // repeat
end;
until not Process32Next(hSnapshot, procEntry);
finally DSiCloseHandleAndNull(hSnapshot); end;
end; { DSiGetProcessID }
{:Retrieves system affinity mask as a list of CPU IDs (0..9, A..V).
@author gabr
@since 2003-11-12
}
function DSiGetSystemAffinity: string;
begin
Result := DSiAffinityMaskToString(DSiGetSystemAffinityMask);
end; { DSiGetSystemAffinity }
{:Retrieves system affinity mask as a DWORD.
@author gabr
@since 2003-11-14
}
function DSiGetSystemAffinityMask: DWORD;
var
processAffinityMask: DWORD;
begin
if not DSiIsWinNT then
Result := 1
else
GetProcessAffinityMask(GetCurrentProcess, processAffinityMask, Result);
end; { TDSiRegistry.DSiGetSystemAffinityMask }
{:Retrieves affinity mask of the current thread as a list of CPU IDs (0..9,
A..V).
@author gabr
@since 2003-11-12
}
function DSiGetThreadAffinity: string;
begin
if not DSiIsWinNT then
Result := '0'
else
Result := DSiAffinityMaskToString(DSiGetThreadAffinityMask);
end; { DSiGetThreadAffinity }
{:Retrieves affinity mask of the current thread as a DWORD.
@author gabr
@since 2003-11-14
}
function DSiGetThreadAffinityMask: DWORD;
var
processAffinityMask: DWORD;
systemAffinityMask : DWORD;
begin
if not DSiIsWinNT then
Result := 1
else begin
GetProcessAffinityMask(GetCurrentProcess, processAffinityMask, systemAffinityMask);
Result := SetThreadAffinityMask(GetCurrentThread, processAffinityMask);
SetThreadAffinityMask(GetCurrentThread, Result);
end;
end; { DSiGetThreadAffinityMask }
{:Returns various times of the current thread.
@author gabr
@since 2007-07-11
}
function DSiGetThreadTimes(var creationTime: TDateTime; var userTime, kernelTime:
int64): boolean;
var
exitTime: TDateTime;
begin
Result := DSiGetThreadTimes(GetCurrentThread, creationTime, exitTime, userTime,
kernelTime);
end; { DSiGetThreadTimes }
{:Returns various times of a thread.
@author gabr
@since 2007-07-11
}
function DSiGetThreadTimes(thread: THandle; var creationTime, exitTime: TDateTime; var
userTime, kernelTime: int64): boolean;
var
fsCreationTime: TFileTime;
fsExitTime : TFileTime;
fsKernelTime : TFileTime;
fsUserTime : FileTime;
begin
Result :=
GetThreadTimes(thread, fsCreationTime, fsExitTime, fsKernelTime, fsUserTime) and
DSiFileTimeToDateTime(fsCreationTime, creationTime) and
DSiFileTimeToDateTime(fsExitTime, exitTime);
if Result then begin
kernelTime := DSiFileTimeToMicroSeconds(fsKernelTime);
userTime := DSiFileTimeToMicroSeconds(fsUserTime);
end;
end; { DSiGetThreadTimes }
{gp}
// Returns True if user can be impersonated. Always True on 9x architecture.
function DSiImpersonateUser(const username, password, domain: string): boolean;
var
dsiDomain : string;
dsiUsername: string;
lastError : DWORD;
logonHandle: THandle;
posDomain : integer;
begin
if not DSiIsWinNT then
Result := true
else begin
Result := false;
dsiDomain := domain;
dsiUsername := username;
if dsiDomain = '.' then begin
posDomain := Pos('\', dsiUsername);
if posDomain > 0 then begin
dsiDomain := Copy(dsiUsername, 1, posDomain-1);
Delete(dsiUsername, 1, posDomain);
end;
end;
if DSiLogonUser(PChar(dsiUsername), PChar(dsiDomain), PChar(password),
LOGON32_LOGON_INTERACTIVE, LOGON32_PROVIDER_DEFAULT, logonHandle) then
begin
Result := DSiImpersonateLoggedOnUser(logonHandle);
lastError := GetLastError;
CloseHandle(logonHandle);
SetLastError(lastError);
end;
end;
end; { DSiImpersonateUser }
{:Increments working set for the current program by a specified ammount of bytes.
@param incMinSize Number of bytes to increment the minimum working set by (may be 0).
@param incMaxSize Number of bytes to increment the maximum working set by (may be 0).
@author gabr
@since 2004-09-21
}
function DSiIncrementWorkingSet(incMinSize, incMaxSize: integer): boolean;
var
hProcess : THandle;
maxWorkingSetSize: DWORD;
minWorkingSetSize: DWORD;
begin
Result := false;
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION OR PROCESS_SET_QUOTA, false,
GetCurrentProcessId);
try
if not GetProcessWorkingSetSize(hProcess, minWorkingSetSize, maxWorkingSetSize) then
Exit;
Inc(minWorkingSetSize, incMinSize);
Inc(maxWorkingSetSize, incMaxSize);
if minWorkingSetSize > maxWorkingSetSize then
maxWorkingSetSize := minWorkingSetSize;
Result := SetProcessWorkingSetSize(hProcess, minWorkingSetSize, maxWorkingSetSize);
finally CloseHandle(hProcess); end;
end; { DSiIncrementWorkingSet }
{mr}
function DSiIsDebugged: boolean;
var
isDebuggerPresent: function: Boolean; stdcall;
kernelHandle : THandle;
p : pointer;
begin
kernelHandle := GetModuleHandle(kernel32);
@isDebuggerPresent := GetProcAddress(kernelHandle, 'IsDebuggerPresent');
if assigned(isDebuggerPresent) then // Win98+/NT4+ only
Result := isDebuggerPresent
else
begin // Win9x uses thunk pointer outside the module when under a debugger
p := GetProcAddress(kernelHandle, 'GetProcAddress');
Result := (DWORD(p) < kernelHandle);
end;
end; { DSiIsDebugged }
{ln}
function DSiOpenURL(const URL: string; newBrowser: boolean): boolean;
begin
if NewBrowser then begin
ShellExecute(0, nil, PChar(DSiGetDefaultBrowser), nil, nil, SW_SHOW);
Sleep(500); // wait a bit to load the browser
end;
Result := (ShellExecute(0, nil, PChar(URL), nil, nil, SW_SHOW) > 32);
end; { DSiOpenURL }
{:Process all messages waiting in the current thread's message queue.
@author gabr
@since 2003-08-25
}
procedure DSiProcessThreadMessages;
var
msg: TMsg;
begin
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) and (Msg.Message <> WM_QUIT) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end; { DSiProcessThreadMessages }
{mr}
function DSiRealModuleName: string;
var
FileName: array[0..MAX_PATH - 1] of Char;
begin
GetModuleFileName(HInstance, FileName, SizeOf(FileName));
Result := string(FileName);
end; { DSiRealModuleName }
{:Sets current process' affinity mask.
@param affinity List of CPUs to include in the affinity mask (0..9, A..V).
May contain processors not available on the system or
processors already excluded from the current process'
affinity mask.
@returns CPUs that were actually included in the affinity mask.
@author gabr
@since 2003-11-12
}
function DSiSetProcessAffinity(affinity: string): string;
begin
SetProcessAffinityMask(GetCurrentProcess,
DSiValidateProcessAffinityMask(DSiStringToAffinityMask(affinity)));
Result := DSiGetProcessAffinity;
end; { DSiSetProcessAffinity }
{:Sets priority class for all processes with the given name. Requires Toolhelp API (e.g.
non-NT4 OS).
@param priority See SetPriorityClass API function.
@author gabr
@since 2004-02-12
}
function DSiSetProcessPriorityClass(const processName: string;
priority: DWORD): boolean;
var
hSnapshot: THandle;
procEntry: TProcessEntry32;
process : THandle;
begin
Result := false;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot = 0 then
Exit;
try
procEntry.dwSize := Sizeof(procEntry);
if not Process32First(hSnapshot, procEntry) then
Exit;
repeat
if AnsiSameText(procEntry.szExeFile, processName) then begin
process := OpenProcess(PROCESS_SET_INFORMATION, false, procEntry.th32ProcessID);
if process = 0 then
Exit;
try
SetPriorityClass(process, priority);
finally DSiCloseHandleAndNull(process); end;
end;
until not Process32Next(hSnapshot, procEntry);
finally DSiCloseHandleAndNull(hSnapshot); end;
end; { TDSiRegistry.DSiSetProcessPriortyClass }
{:Sets current thread's affinity mask.
@param affinity List of CPUs to include in the affinity mask (0..9, A..V).
May contain processors not available on the system or
processors already excluded from the current process' or
thread's affinity mask.
@returns CPUs that were actually included in the affinity mask.
@author gabr
@since 2003-11-12
}
function DSiSetThreadAffinity(affinity: string): string;
begin
SetThreadAffinityMask(GetCurrentThread,
DSiValidateThreadAffinityMask(DSiStringToAffinityMask(affinity)));
Result := DSiGetThreadAffinity;
end; { DSiSetThreadAffinity }
{gp}
// Reverts back to the original program 'personae'. Does nothing on the 9x architecture.
procedure DSiStopImpersonatingUser;
begin
if DSiIsWinNT then
DSiRevertToSelf;
end; { DSiStopImpersonatingUser }
{:Convert affinity list (0..9, A..V) to the DWORD mask.
@author gabr
@since 2003-11-14
}
function DSiStringToAffinityMask(affinity: string): DWORD;
var
idxID: integer;
begin
Result := 0;
for idxID := 32 downto 1 do begin
Result := Result SHL 1;
if Pos(DSiCPUIDs[idxID], affinity) > 0 then
Result := Result OR 1;
end; //for
end; { DSiStringToAffinityMask }
function DSiSendWMCloseToWindow(hWindow: THandle; lParam: integer): BOOL; stdcall;
var
idWindow: DWORD;
begin
GetWindowThreadProcessId(hWindow, idWindow);
if idWindow = DWORD(lParam) then
PostMessage(hWindow, WM_CLOSE, 0, 0);
Result := true;
end; { DSiSendWMCloseToWindow }
{:Terminates process by ID.
Source: http://support.microsoft.com/kb/178893
@author M.C, gabr
@since 2007-12-14
}
function DSiTerminateProcessById(processID: DWORD; closeWindowsFirst: boolean;
maxWait_sec: integer): boolean;
var
hProcess: THandle;
begin
Result := false;
hProcess := OpenProcess(SYNCHRONIZE OR PROCESS_TERMINATE, false, processID);
if hProcess = 0 then
Exit;
try
if closeWindowsFirst then begin
EnumWindows(@DSiSendWMCloseToWindow, integer(processID));
Result := (WaitForSingleObject(hProcess, maxWait_sec * 1000) = WAIT_OBJECT_0);
end;
if not Result then
Result := TerminateProcess(hProcess, 0);
finally CloseHandle(hProcess); end;
end; { DSiTerminateProcessById }
{mr}
procedure DSiTrimWorkingSet;
var
hProcess: THandle;
begin
hProcess := OpenProcess(PROCESS_SET_QUOTA, false, GetCurrentProcessId);
try
SetProcessWorkingSetSize(hProcess, $FFFFFFFF, $FFFFFFFF);
finally CloseHandle(hProcess); end;
end; { DSiTrimWorkingSet }
{:Validates process affinity mask (removes all CPUs that are not in the
system affinity mask).
@author gabr
@since 2003-11-14
}
function DSiValidateProcessAffinity(affinity: string): string;
begin
Result := DSiAffinityMaskToString(DSiValidateProcessAffinityMask(
DSiStringToAffinityMask(affinity)));
end; { DSiValidateProcessAffinity }
{:Validates process affinity mask (removes all CPUs that are not in the
system affinity mask).
@author gabr
@since 2003-11-14
}
function DSiValidateProcessAffinityMask(affinityMask: DWORD): DWORD;
begin
Result := DSiGetSystemAffinityMask AND affinityMask;
end; { TDSiRegistry.DSiValidateProcessAffinityMask }
{:Validates process affinity mask (removes all CPUs that are not in the
system affinity mask).
@author gabr
@since 2003-11-14
}
function DSiValidateThreadAffinity(affinity: string): string;
begin
Result := DSiAffinityMaskToString(DSiValidateThreadAffinityMask(
DSiStringToAffinityMask(affinity)));
end; { DSiValidateThreadAffinityMask }
function DSiValidateThreadAffinityMask(affinityMask: DWORD): DWORD;
begin
Result := DSiGetProcessAffinityMask AND affinityMask;
end; { DSiValidateThreadAffinityMask }
procedure DSiYield;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
SwitchToThread
else
Sleep(1);
end; { DSiYield }
{ Memory }
{mr}
procedure DSiFreePidl(pidl: PItemIDList);
var
allocator: IMalloc;
begin
if Succeeded(SHGetMalloc(allocator)) then begin
allocator.Free(pidl);
{$IFDEF VER90}
allocator.Release;
{$ENDIF}
end;
end; { DSiFreePidl }
{:Frees memory allocated with GetMem and nils the pointer to the memory.
Does nothing if pointer is already nil.
@author: gp
@since 2003-05-24
}
procedure DSiFreeMemAndNil(var mem: pointer);
var
tmp: pointer;
begin
if assigned(mem) then begin
tmp := mem;
mem := nil;
FreeMem(tmp);
end;
end; { DSiFreeMemAndNil }
{ Windows }
const //DSiAllocateHwnd window extra data offsets
GWL_METHODCODE = SizeOf(pointer) * 0;
GWL_METHODDATA = SizeOf(pointer) * 1;
//DSiAllocateHwnd hidden window (and window class) name
CDSiHiddenWindowName = 'DSiUtilWindow';
var
//DSiAllocateHwnd lock
GDSiWndHandlerCritSect: TRTLCriticalSection;
//Count of registered windows in this instance
GDSiWndHandlerCount: integer;
{:Class message dispatcher for the DSiUtilWindow class. Fetches instance's WndProc from
the window extra data and calls it.
}
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
var
instanceWndProc: TMethod;
msg : TMessage;
begin
instanceWndProc.Code := Pointer(GetWindowLong(Window, GWL_METHODCODE));
instanceWndProc.Data := Pointer(GetWindowLong(Window, GWL_METHODDATA));
if Assigned(TWndMethod(instanceWndProc)) then
begin
msg.msg := Message;
msg.wParam := WParam;
msg.lParam := LParam;
TWndMethod(instanceWndProc)(msg);
Result := msg.Result
end
else
Result := DefWindowProc(Window, Message, WParam,LParam);
end; { DSiClassWndProc }
{:Thread-safe AllocateHwnd.
@author gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
@since 2007-05-30
}
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
var
alreadyRegistered: boolean;
tempClass : TWndClass;
utilWindowClass : TWndClass;
begin
Result := 0;
FillChar(utilWindowClass, SizeOf(utilWindowClass), 0);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
alreadyRegistered := GetClassInfo(HInstance, CDSiHiddenWindowName, tempClass);
if (not alreadyRegistered) or (tempClass.lpfnWndProc <> @DSiClassWndProc) then begin
if alreadyRegistered then
Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
utilWindowClass.lpszClassName := CDSiHiddenWindowName;
utilWindowClass.hInstance := HInstance;
utilWindowClass.lpfnWndProc := @DSiClassWndProc;
utilWindowClass.cbWndExtra := SizeOf(TMethod);
if Windows.RegisterClass(utilWindowClass) = 0 then
raise Exception.CreateFmt('Unable to register DSiWin32 hidden window class. %s',
[SysErrorMessage(GetLastError)]);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, CDSiHiddenWindowName, '', WS_POPUP,
0, 0, 0, 0, 0, 0, HInstance, nil);
if Result = 0 then
raise Exception.CreateFmt('Unable to create DSiWin32 hidden window. %s',
[SysErrorMessage(GetLastError)]);
SetWindowLong(Result, GWL_METHODDATA, Longint(TMethod(wndProcMethod).Data));
SetWindowLong(Result, GWL_METHODCODE, Longint(TMethod(wndProcMethod).Code));
Inc(GDSiWndHandlerCount);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiAllocateHWnd }
{:Thread-safe DeallocateHwnd.
@author gabr [based on http://fidoforum.ru/pages/new46s35o217746.ru.delphi and
TIcsWndHandler.AllocateHWnd from ICS v6 (http://www.overbyte.be)]
@since 2007-05-30
}
procedure DSiDeallocateHWnd(wnd: HWND);
begin
if wnd = 0 then
Exit;
DestroyWindow(wnd);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
Dec(GDSiWndHandlerCount);
if GDSiWndHandlerCount <= 0 then
Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end; { DSiDeallocateHWnd }
{:Disables 'X' button and Alt+F4.
@author aoven
@since 2003-09-02
}
procedure DSiDisableX(hwnd: THandle);
begin
EnableMenuItem(GetSystemMenu(hwnd, false), SC_CLOSE, MF_BYCOMMAND or MF_DISABLED);
end; { DSiDisableX }
{:Enables 'X' button and Alt+F4.
@author gabr
@since 2003-09-02
}
procedure DSiEnableX(hwnd: THandle);
begin
EnableMenuItem(GetSystemMenu(hwnd, false), SC_CLOSE, MF_BYCOMMAND or MF_ENABLED);
end; { DSiEnableX }
const
EWX_LOGOFF_FORCE = $00;
EWX_POWEROFF_FORCE = $0A;
EWX_REBOOT_FORCE = $06;
EWX_SHUTDOWN_FORCE = $05;
CExitWindows: array [TDSiExitWindows] of integer = (EWX_LOGOFF, EWX_LOGOFF_FORCE,
EWX_POWEROFF, EWX_POWEROFF_FORCE, EWX_REBOOT, EWX_REBOOT_FORCE, EWX_SHUTDOWN,
EWX_SHUTDOWN_FORCE);
{:Exits (logoff, shutdown, restart) the Windows.
@author xtreme
@since 2005-02-13
}
function DSiExitWindows(exitType: TDSiExitWindows): boolean;
begin
Result := false;
if DSiEnablePrivilege('SeShutdownPrivilege') then
Result := ExitWindowsEx(CExitWindows[exitType], 0);
end; { DSiExitWindows }
{gp}
function DSiForceForegroundWindow(hwnd: THandle; restoreFirst: boolean): boolean;
var
ForegroundThreadID: DWORD;
ThisThreadID : DWORD;
timeout : DWORD;
begin
if restoreFirst then
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd then Result := true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then
begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result := false;
ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then begin
BringWindowToTop(hwnd); //IE 5.5 - related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false);
Result := (GetForegroundWindow = hwnd);
end;
if not Result then begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); //IE 5.5 - related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
end;
end
else begin
BringWindowToTop(hwnd); //IE 5.5 - related hack
SetForegroundWindow(hwnd);
end;
Result := (GetForegroundWindow = hwnd);
end;
end; { DSiForceForegroundWindow }
{gp}
function DSiGetClassName(hwnd: THandle): string;
var
winClass: array [0..1024] of char;
begin
if GetClassName(hwnd, winClass, SizeOf(winClass)) <> 0 then
Result := winClass
else
Result := '';
end; { DSiGetClassName }
type
TProcWndInfo = record
TargetProcessID: DWORD;
FoundWindow : HWND;
end; { TProcWndInfo }
PProcWndInfo = ^TProcWndInfo;
function EnumGetProcessWindow(wnd: HWND; userParam: LPARAM): BOOL; stdcall;
var
wndProcessID: DWORD;
begin
GetWindowThreadProcessId(wnd, @wndProcessID);
if (wndProcessID = PProcWndInfo(userParam)^.TargetProcessID) and
(GetWindowLong(wnd, GWL_HWNDPARENT) = 0) then
begin
PProcWndInfo(userParam)^.FoundWindow := Wnd;
Result := false;
end
else
Result := true;
end; { EnumGetProcessWindow }
{ln}
function DSiGetProcessWindow(targetProcessID: cardinal): HWND;
var
procWndInfo: TProcWndInfo;
begin
procWndInfo.TargetProcessID := targetProcessID;
procWndInfo.FoundWindow := 0;
EnumWindows(@EnumGetProcessWindow, LPARAM(@procWndInfo));
Result := procWndInfo.FoundWindow;
end; { DSiGetProcessWindow }
{gp}
function DSiGetWindowText(hwnd: THandle): string;
var
winText: array [0..1024] of char;
begin
if GetWindowText(hwnd, winText, SizeOf(winText)) <> 0 then
Result := winText
else
Result := '';
end; { DSiGetWindowTextStr }
{:Processes all waiting window messages.
@author gabr
@since 2003-08-18
}
procedure DSiProcessMessages(hwnd: THandle; waitForWMQuit: boolean);
var
bGet: longint;
msg : TMsg;
begin
if hwnd = 0 then
Exit;
repeat
if not waitForWMQuit then begin
if not PeekMessage(msg, hwnd, 0, 0, PM_REMOVE) then
break; //repeat
end
else begin
bGet := longint(GetMessage(msg, hwnd, 0, 0));
if (bGet = 0) or (bGet = -1) then
break; //repeat
end;
TranslateMessage(Msg);
DispatchMessage(Msg);
until msg.Message = WM_QUIT;
end; { DSiProcessMessages }
{xtreme}
procedure DSiRebuildDesktopIcons;
var
dwResult: cardinal;
oldSize : integer;
registry: TRegistry;
const
CShellIconSize = 'Shell Icon Size';
CTimeout = 10000;
begin
registry := TRegistry.Create;
try
if not registry.OpenKey('Control Panel\Desktop\WindowMetrics', false) then
Exit;
if registry.ValueExists(CShellIconSize) then
oldSize := StrToInt(registry.ReadString(CShellIconSize))
else
oldSize := 0;
registry.WriteString(CShellIconSize, IntToStr(oldSize + 1));
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
SPI_SETNONCLIENTMETRICS, 0, SMTO_ABORTIFHUNG, CTimeout, dwResult);
if oldSize > 0 then
registry.WriteString(CShellIconSize, IntToStr(oldSize))
else
registry.DeleteValue(CShellIconSize);
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
SPI_SETNONCLIENTMETRICS,0, SMTO_ABORTIFHUNG, CTimeout, dwResult);
registry.CloseKey;
finally FreeAndNil(registry);end;
end; { DSiRebuildDesktopIcons }
{xtreme}
procedure DSiRefreshDesktop;
var
handleDesktop: HWND;
begin
handleDesktop := FindWindowEx(FindWindowEx(FindWindow('Progman',
'Program Manager'), 0, 'SHELLDLL_DefView', ''), 0, 'SysListView32', '');
PostMessage(handleDesktop, WM_DDE_FIRST, VK_F5, 0);
PostMessage(handleDesktop, WM_DDE_LAST, VK_F5, 1 shl 31);
end; { DSiRefreshDesktop }
{ln}
procedure DSiSetTopMost(hwnd: THandle; onTop, activate: boolean);
const
cTopMost : array [boolean] of THandle = (HWND_NOTOPMOST, HWND_TOPMOST);
cActivate: array [boolean] of UINT = (SWP_NOACTIVATE, 0);
begin
SetWindowPos(hwnd, cTopMost[OnTop], 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or cActivate[Activate]);
end; { DSiSetTopMost }
{ Aero }
///Disables Aero interface on Vista. Does nothing on older platforms.
///True if Aero was disabled or if Aero is not supported.
///gabr
///Based on code by David J Taylor published in
/// news://borland.public.delphi.language.delphi.win32.
///2007-10-25
function DSiAeroDisable: boolean;
begin
Result := (DSiDwmEnableComposition(DWM_EC_DISABLECOMPOSITION) = S_OK);
if not assigned(GDwmEnableComposition) then
Result := true;
end; { DSiAeroDisable }
///Enables Aero interface on Vista. Does nothing on older platforms.
///True if Aero was enabled. False if Aero is not supported.
///gabr
///Based on code by David J Taylor published in
/// news://borland.public.delphi.language.delphi.win32.
///2007-10-25
function DSiAeroEnable: boolean;
begin
Result := (DSiDwmEnableComposition(DWM_EC_ENABLECOMPOSITION) = S_OK);
end; { DSiAeroEnable }
///Checks if Aero interface is enabled.
///True if Aero is enabled. False if Aero is disabled or not supported.
///gabr
///2007-10-25
function DSiAeroIsEnabled: boolean;
var
isEnabled: BOOL;
begin
Result := (DSiDwmIsCompositionEnabled(isEnabled) = S_OK);
if Result then
Result := isEnabled;
end; { DSiAeroIsEnabled }
{ Taskbar }
{ln}
function DSiGetTaskBarPosition: integer;
var
pData: TAppBarData;
begin
Result := -1;
pData.cbSize := SizeOf(TAppBarData);
pData.hWnd := 0;
if SHAppBarMessage(ABM_GETTASKBARPOS, pData) = 0 then
Exit;
Result := pData.uEdge;
end; { DSiGetTaskBarPosition }
{ Menus }
{gp}
function DSiGetHotkey(const item: string): char;
var
item2: string;
p : integer;
begin
item2 := StringReplace(item, '&&', '&', [rfReplaceAll]);
p := Pos('&', item2);
if (p > 0) and (p < Length(item2)) then
Result := UpCase(item2[p+1])
else
Result := #0;
end; { DSiGetHotkey }
{gp}
function DSiGetMenuItem(menu: HMENU; item: integer): string;
var
res: integer;
buf: array [0..1024] of char;
begin
res := GetMenuString(menu, item, buf, SizeOf(buf), MF_BYPOSITION);
if res > 0 then
Result := buf
else
Result := '';
end; { DSiGetMenuItem }
{ Screen }
{mr}
procedure DSiDisableScreenSaver(out currentlyActive: boolean);
var
isActive: BOOL;
begin
SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @isActive, 0);
currentlyActive := isActive;
if currentlyActive then
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, UINT(false), nil, SPIF_SENDWININICHANGE);
end; { DSiDisableScreenSaver }
{mr}
procedure DSiEnableScreenSaver;
begin
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, UINT(true), nil, SPIF_SENDWININICHANGE);
end; { DSiEnableScreenSaver }
{mr}
function DSiGetBitsPerPixel: integer;
var
h: hDC;
begin
h := GetDC(0);
try
Result := GetDeviceCaps(h, BITSPIXEL);
finally ReleaseDC(0, h); end;
end; { DSiGetBitsPerPixel }
{mr}
function DSiGetBPP: integer;
var
DC: HDC;
begin
DC := GetDC(0);
try
Result := GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES);
finally ReleaseDC(0, DC); end;
end; { DSiGetBPP }
{mr}
function DSiGetDesktopSize: TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
end; { DSiGetDesktopSize }
{ln}
function DSiIsFullScreen: boolean;
var
desktopRect : TRect;
foregroundRect: TRect;
begin
Result :=
GetWindowRect(GetForegroundWindow, foregroundRect) and
GetWindowRect(GetDesktopWindow, desktopRect) and
(not PtInRect(desktopRect, foregroundRect.TopLeft)) and
(not PtInRect(desktopRect, foregroundRect.BottomRight));
end; { DSiIsFullScreen }
{ales}
procedure DSiMonitorOff;
begin
SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, 2);
end; { DSiMonitorOff }
{ales}
procedure DSiMonitorOn;
begin
SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
end; { DSiMonitorOn }
{gp}
procedure DSiMonitorStandby;
begin
SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, 1);
end; { DSiMonitorOff }
{matijap}
function DSiSetScreenResolution(width, height: integer): longint;
var
deviceMode: TDeviceMode;
begin
with deviceMode do begin
dmSize := SizeOf(TDeviceMode);
dmPelsWidth := width;
dmPelsHeight := height;
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
end;
Result := ChangeDisplaySettings(DeviceMode, CDS_UPDATEREGISTRY);
end; { DSiSetScreenResolution }
{ Rectangles }
{:Centers rectangle over another rectangle.
@since 2007-12-29
@author gabr
}
procedure DSiCenterRectInRect(const ownerRect: TRect; var clientRect: TRect);
var
clientCenter: TPoint;
ownerCenter : TPoint;
begin
ownerCenter := CenterPoint(ownerRect);
clientCenter := CenterPoint(clientRect);
OffsetRect(clientRect, ownerCenter.X - clientCenter.X, ownerCenter.Y - clientCenter.Y);
end; { DSiCenterRectInRect }
{:Makes sure rectangle is fully placed inside another rectangle.
@since 2007-12-29
@author gabr
}
procedure DSiMakeRectFullyVisibleOnRect(const ownerRect: TRect; var clientRect: TRect);
begin
if clientRect.Left < ownerRect.Left then
OffsetRect(clientRect, ownerRect.Left - clientRect.Left, 0)
else if clientRect.Right > ownerRect.Right then
OffsetRect(clientRect, ownerRect.Right - clientRect.Right, 0);
if clientRect.Top < ownerRect.Top then
OffsetRect(clientRect, 0, ownerRect.Top - clientRect.Top)
else if clientRect.Bottom > ownerRect.Bottom then
OffsetRect(clientRect, 0, ownerRect.Bottom - clientRect.Bottom);
end; { DSiMakeRectFullyVisibleOnRect }
{ Clipboard }
var
GCF_HTML: UINT;
{:Checks if HTML format is stored on the clipboard.
@since 2008-04-29
@author gabr
}
function DSiIsHtmlFormatOnClipboard: boolean;
begin
Result := IsClipboardFormatAvailable(GCF_HTML);
end; { DSiIsHtmlFormatOnClipboard }
{:Retrieves HTML format from the clipboard. If there is no HTML format on the clipboard,
function returns empty string.
@since 2008-04-29
@author MP002, gabr
}
function DSiGetHtmlFormatFromClipboard: string;
var
hClipData : THandle;
idxEndFragment : integer;
idxStartFragment: integer;
pClipData : PChar;
begin
Result := '';
if DSiIsHtmlFormatOnClipboard then begin
Win32Check(OpenClipboard(0));
try
hClipData := GetClipboardData(GCF_HTML);
if hClipData <> 0 then begin
pClipData := GlobalLock(hClipData);
Win32Check(assigned(pClipData));
try
idxStartFragment := Pos('', pClipData); // len = 20
idxEndFragment := Pos('', pClipData);
if (idxStartFragment >= 0) and (idxEndFragment >= idxStartFragment) then
Result := Copy(pClipData, idxStartFragment + 20, idxEndFragment - idxStartFragment - 20);
finally GlobalUnlock(hClipData); end;
end;
finally Win32Check(CloseClipboard); end;
end;
end; { DSiGetHtmlFormatFromClipboard }
{:Copies HTML (and, optionally, text) format to the clipboard.
@since 2008-04-29
@author MP002, gabr
}
procedure DSiCopyHtmlFormatToClipboard(const sHtml, sText: string);
function MakeFragment(const sHtml: string): string;
const
CVersion = 'Version:1.0'#13#10;
CStartHTML = 'StartHTML:';
CEndHTML = 'EndHTML:';
CStartFragment = 'StartFragment:';
CEndFragment = 'EndFragment:';
CHTMLIntro = 'HTML clipboard';
CHTMLExtro = '';
CNumberLengthAndCR = 10;
CDescriptionLength = // Let the compiler determine the description length.
Length(CVersion) + Length(CStartHTML) + Length(CEndHTML) +
Length(CStartFragment) + Length(CEndFragment) + 4*CNumberLengthAndCR;
var
description : string;
idxEndFragment : integer;
idxEndHtml : integer;
idxStartFragment: integer;
idxStartHtml : integer;
begin
// The sHtml clipboard format is defined by using byte positions in the entire block
// where sHtml text and fragments start and end. These positions are written in a
// description. Unfortunately the positions depend on the length of the description
// but the description may change with varying positions. To solve this dilemma the
// offsets are converted into fixed length strings which makes it possible to know
// the description length in advance.
idxStartHtml := CDescriptionLength; // position 0 after the description
idxStartFragment := idxStartHtml + Length(CHTMLIntro);
idxEndFragment := idxStartFragment + Length(sHtml);
idxEndHtml := idxEndFragment + Length(CHTMLExtro);
description := CVersion +
SysUtils.Format('%s%.8d', [CStartHTML, idxStartHtml]) + #13#10 +
SysUtils.Format('%s%.8d', [CEndHTML, idxEndHtml]) + #13#10 +
SysUtils.Format('%s%.8d', [CStartFragment, idxStartFragment]) + #13#10 +
SysUtils.Format('%s%.8d', [CEndFragment, idxEndFragment]) + #13#10;
Result := description + CHTMLIntro + sHtml + CHTMLExtro;
end; { MakeFragment }
var
clipFormats: array[0..1] of UINT;
clipStrings: array[0..1] of string;
hClipData : HGLOBAL;
iFormats : integer;
pClipData : PChar;
begin { DSiCopyHtmlFormatToClipboard }
Win32Check(OpenClipBoard(0));
try
//most descriptive first as per api docs
clipStrings[0] := MakeFragment(sHtml);
if sText = '' then
clipStrings[1] := sHtml
else
clipStrings[1] := sText;
clipFormats[0] := GCF_HTML;
clipFormats[1] := CF_TEXT;
Win32Check(EmptyClipBoard);
for iFormats := 0 to High(clipStrings) do begin
if clipStrings[iFormats] = '' then
continue;
hClipData := GlobalAlloc(GMEM_DDESHARE + GMEM_MOVEABLE, Length(clipStrings[iFormats]) + 1);
Win32Check(hClipData <> 0);
try
pClipData := GlobalLock(hClipData);
Win32Check(assigned(pClipData));
try
Move(PChar(clipStrings[iFormats])^, pClipData^, Length(clipStrings[iFormats]) + 1);
finally GlobalUnlock(hClipData); end;
Win32Check(SetClipboardData(clipFormats[iFormats], hClipData) <> 0);
hClipData := 0;
finally
if hClipData <> 0 then
GlobalFree(hClipData);
end;
end;
finally Win32Check(CloseClipboard); end;
end; { DSiCopyHtmlFormatToClipboard }
{ Information }
{:Retrieves application compatibility flags. Works around WOW64 problems.
@since 2007-02-11
@author Miha-R, gabr
}
function DSiGetAppCompatFlags(const exeName: string): string;
var
wow64key: HKEY;
begin
Result := DSiReadRegistry(
'Software\Microsoft\Windows NT\CurrentVersion\AppCompatFlags\Layers',
exeName, '', HKEY_CURRENT_USER);
if DSiIsWow64 then
wow64key := KEY_WOW64_64KEY
else
wow64key := 0;
Result := Result + ' ' + DSiReadRegistry(
'Software\Microsoft\Windows NT\CurrentVersion\AppCompatFlags\Layers',
exeName, '', HKEY_LOCAL_MACHINE, KEY_QUERY_VALUE OR wow64key);
Result := Trim(Result);
end; { DSiGetAppCompatFlags }
{:Returns type of a last boot.
@author ales, gabr
@since 2003-09-02
}
function DSiGetBootType: TDSiBootType;
var
iBoot: integer;
begin
iBoot := GetSystemMetrics(SM_CLEANBOOT);
if iBoot = 0 then
Result := btNormal
else if iBoot = 1 then
Result := btFailSafe
else if iBoot = 2 then
Result := btFailSafeWithNetwork
else
Result := btUnknown;
end; { DSiGetBootType }
{:Returns name of the licensee organisation.
@author Lee_Nover
@since 2002-11-25
}
function DSiGetCompanyName: string;
begin
Result := DSiReadRegistry(DSiWinVerKeys[DSiIsWinNT], 'RegisteredOrganization', '',
HKEY_LOCAL_MACHINE);
end; { DSiGetCompanyName }
{:Returns computer name.
@author Miha-R
@since 2002-11-25
}
function DSiGetComputerName: string;
var
buffer : PChar;
bufferSize: DWORD;
begin
bufferSize := MAX_COMPUTERNAME_LENGTH+1;
GetMem(buffer, bufferSize);
try
GetComputerName(buffer, bufferSize);
SetLength(Result, StrLen(buffer));
if Result <> '' then
Move(buffer^, Result[1], Length(Result));
finally FreeMem(buffer); end;
end; { DSiGetComputerName }
{:Returns path to default web browser.
@author Lee_Nover
@since 2002-11-25
}
function DSiGetDefaultBrowser: string;
begin
Result := DSiReadRegistry('http\shell\open\command', '', '', HKEY_CLASSES_ROOT);
end; { DSiGetDefaultBrowser }
{:Returns DirectX version.
@author Lee_Nover
@since 2002-11-25
}
function DSiGetDirectXVer: string;
begin
Result := DSiReadRegistry('\Software\Microsoft\DirectX', 'Version', '',
HKEY_LOCAL_MACHINE);
end; { DSiGetDirectXVer }
{:Returns name of the operating system licensee.
@author Lee_Nover
@since 2002-11-25
}
function DSiGetRegisteredOwner: string;
begin
Result := DSiReadRegistry(DSiWinVerKeys[DSiIsWinNT], 'RegisteredOwner', '',
HKEY_LOCAL_MACHINE);
end; { DSiGetRegisteredOwner }
{:Returns disk label of the specified drive.
@author Odisej
@since 2003-10-09
}
function DSiGetDiskLabel(disk: char): string;
var
fileSysFlags: DWORD;
maxCompLen : DWORD;
volName : array [0..MAX_PATH] of char;
begin
if GetVolumeInformation(PChar(disk+':\'), volName, SizeOf(volName)-1,
nil, maxCompLen, fileSysFlags, nil, 0)
then
Result := volName
else
Result := '';
end; { DSiGetDiskLabel }
{:Returns serial number of the specified drive.
@author ales
@since 2002-11-25
}
function DSiGetDiskSerial(disk: char): string;
var
fileSysFlags: DWORD;
maxCompLen : DWORD;
serNum : DWORD;
begin
GetVolumeInformation(PChar(disk+':\'), nil, 0, @serNum,
maxCompLen, fileSysFlags, nil, 0);
Result := Format('%.4x-%.4x', [HiWord(serNum), LoWord(serNum)]);
end; { DSiGetDiskSerial }
{:Helper function returning current domain on an NT system.
@author Lee_Nover
@since 2003-09-02
}
function GetDomainNT: string;
var
pwi: PWkstaInfo100;
begin
if DSiNetWkstaGetInfo(nil, 100, pointer(pwi)) = 0 then
Result := string(pwi.wki100_langroup)
else
Result := '';
end; { GetDomainNT }
{:Returns the domain system is logged onto.
@author Lee_Nover
@since 2003-09-02
}
function DSiGetDomain: string;
begin
if DSiIsWinNT then
Result := GetDomainNT
else begin
Result := DSiReadRegistry(
'\System\CurrentControlSet\Services\MSNP32\NetworkProvider',
'AuthenticatingAgent', '', HKEY_LOCAL_MACHINE);
if Result = '' then // 9x
Result := DSiReadRegistry(
'\System\CurrentControlSet\Services\VXD\VNETSUP',
'Workgroup', '', HKEY_LOCAL_MACHINE);
end;
end; { DSiGetDomain }
{:Returns value of an environment variable.
@author gabr
@since 2005-06-06
}
function DSiGetEnvironmentVariable(const envVarName: string): string;
var
bufSize: integer;
begin
Result := '';
bufSize := GetEnvironmentVariable(PChar(envVarName), nil, 0);
if bufSize <> 0 then begin
SetLength(Result, bufSize-1);
if GetEnvironmentVariable(PChar(envVarName), PChar(Result), bufSize) = 0 then
Result := '';
end;
end; { DSiGetEnvironmentVariable }
{:Returns location of a special folder.
@author Miha-R
@since 2002-11-25
}
function DSiGetFolderLocation(const CSIDL: integer): string;
var
path : PChar;
pPIDL: PItemIDList;
begin
GetMem(path, MAX_PATH);
try
if Succeeded(SHGetSpecialFolderLocation(0, CSIDL, pPIDL)) then begin
SHGetPathFromIDList(pPIDL, path);
DSiFreePidl(pPIDL);
end
else
StrCopy(path, '');
Result := string(path);
finally FreeMem(path); end;
end; { DSiGetFolderLocation }
{:Returns list of available keyboard layouts. Objects[] property contains pointer to
locale data, returned by the GetLocaleInfo.
@since 2005-02-13
}
procedure DSiGetKeyboardLayouts(layouts: TStrings);
var
iLayout : integer;
keyLayList: array [0..9] of HKL;
keyLayouts: array [0..255] of char;
begin
layouts.Clear;
for iLayout := 0 to GetKeyboardLayoutList(SizeOf(keyLayList), keyLayList) - 1 do begin
GetLocaleInfo(LoWord(keyLayList[iLayout]), LOCALE_SLANGUAGE, keyLayouts,
SizeOf(keyLayouts));
layouts.AddObject(keyLayouts, pointer(keyLayList[iLayout]));
end;
end; { DSiGetKeyboardLayouts }
{:Returns My Documents folder.
@author xtreme
@since 2003-10-09
}
function DSiGetMyDocumentsFolder: string;
begin
Result := DSiReadRegistry(
'\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
'Personal', '');
end; { DSiGetMyDocumentsFolder }
{:Returns program files folder (i.e. C:\Program Files or similar).
@author gabr
@since 2002-11-25
}
function DSiGetProgramFilesFolder: string;
begin
Result := DSiReadRegistry('\Software\Microsoft\Windows\CurrentVersion',
'ProgramFilesDir', '', HKEY_LOCAL_MACHINE);
end; { DSiGetProgramFilesFolder }
{:Returns system folder (i.e. C:\Windows\System32 or similar).
@author Miha-R
@since 2002-11-25
}
function DSiGetSystemFolder: string;
var
path: array [1..MAX_PATH] of char;
begin
if GetSystemDirectory(@path, MAX_PATH) <> 0 then
Result := StrPas(PChar(@path))
else
Result := '';
end; { DSiGetSystemDirectory }
{:Returns system default language formatted as a string.
@author xtreme
@since 2005-02-13
}
function DSiGetSystemLanguage: string;
var
lngID : LANGID;
lngName: array [0..127] of char;
begin
lngID := GetSystemDefaultLangID;
VerLanguageName(lngID, lngName, 127);
Result := lngName;
end; { DSiGetSystemLanguage }
{:Returns extended information on operating system version (service pack level etc).
@author xtreme
@since 2003-10-09
}
function DSiGetSystemVersion: string;
var
versionInfo: TOSVersionInfo;
begin
try
versionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(versionInfo);
finally
Result := versionInfo.szCSDVersion;
end;
end; { DSiGetSystemVersion }
{:Tries to return a true OS version when application has compatibility flags set.
@since 2007-02-11
@author Miha-R, gabr
}
function DSiGetTrueWindowsVersion: TDSiWindowsVersion;
function ExportsAPI(module: HMODULE; const apiName: string): boolean;
begin
Result := GetProcAddress(module, PChar(apiName)) <> nil;
end; { ExportsAPI }
var
hKernel32: HMODULE;
begin { DSiGetTrueWindowsVersion }
hKernel32 := GetModuleHandle('kernel32');
Win32Check(hKernel32 <> 0);
if ExportsAPI(hKernel32, 'GetLocaleInfoEx') then
Result := wvWinVista
else if ExportsAPI(hKernel32, 'GetLargePageMinimum') then
Result := wvWinServer2003
// else if ExportsAPI(hKernel32, 'GetDLLDirectory') then
// Result := wvWinXPSP1
else if ExportsAPI(hKernel32, 'GetNativeSystemInfo') then
Result := wvWinXP
else if ExportsAPI(hKernel32, 'ReplaceFile') then
Result := wvWin2000
else if ExportsAPI(hKernel32, 'OpenThread') then
Result := wvWinME
else if ExportsAPI(hKernel32, 'GetThreadPriorityBoost') then
Result := wvWinNT4
else if ExportsAPI(hKernel32, 'IsDebuggerPresent') then // is also in NT4!
Result := wvWin98
else if ExportsAPI(hKernel32, 'GetDiskFreeSpaceEx') then // is also in NT4!
Result := wvWin95OSR2
else if ExportsAPI(hKernel32, 'ConnectNamedPipe') then
Result := wvWinNT3
else if ExportsAPI(hKernel32, 'Beep') then
Result := wvWin95
else // we have no idea
Result := DSiGetWindowsVersion;
end; { DSiGetTrueWindowsVersion }
{:Returns user name of the current thread.
@author Miha-R, Lee_Nover
@since 2002-11-25
}
function DSiGetUserName: string;
var
buffer : PChar;
bufferSize: DWORD;
begin
bufferSize := 128;
buffer := AllocMem(bufferSize);
try
GetUserName(buffer, bufferSize);
Result := string(buffer);
finally FreeMem(buffer, bufferSize); end;
end; { DSiGetUserName }
{:Returns name of the user owning the desktop (currently logged user).
@author Lee_Nover
@since 2003-09-03
}
function DSiGetUserNameEx: string;
var
dwProcessId: DWORD;
h : HWND;
hProcess : THandle;
hToken : THandle;
begin
Result := '';
h := FindWindow('Progman', nil);// maybe use GetDesktopWindow
if h = 0 then
Exit;
if GetWindowThreadProcessId(h, @dwProcessId) = 0 then
Exit;
hProcess := OpenProcess(PROCESS_ALL_ACCESS, FALSE, dwProcessId);
if hProcess = 0 then
Exit;
try
if OpenProcessToken(hProcess, TOKEN_ALL_ACCESS, hToken) then
try
ImpersonateLoggedOnUser(hToken);
try
Result := DSiGetUserName;
finally RevertToSelf; end;
finally CloseHandle(hToken); end;
finally CloseHandle(hProcess); end;
end; { TDSiRegistry.DSiGetUserNameEx }
{:Returns Windows folder (i.e. C:\Windows or similar).
@author Miha-R
@since 2002-11-25
}
function DSiGetWindowsFolder: string;
var
path: PChar;
begin
GetMem(path, MAX_PATH);
try
if GetWindowsDirectory(path, MAX_PATH) <> 0 then
Result := string(path)
else
Result := '';
finally FreeMem(path); end;
end; { DSiGetWindowsFolder }
{:Returns detailed Windows version.
@author xtreme, ales
@since 2003-10-09
}
function DSiGetWindowsVersion: TDSiWindowsVersion;
var
versionInfo: TOSVersionInfo;
begin
versionInfo.dwOSVersionInfoSize := SizeOf(versionInfo);
GetVersionEx(versionInfo);
Result := wvUnknown;
case versionInfo.dwPlatformID of
VER_PLATFORM_WIN32s: Result := wvWin31;
VER_PLATFORM_WIN32_WINDOWS:
case versionInfo.dwMinorVersion of
0:
if Trim(versionInfo.szCSDVersion[1]) = 'B' then
Result := wvWin95OSR2
else
Result := wvWin95;
10:
if Trim(versionInfo.szCSDVersion[1]) = 'A' then
Result := wvWin98SE
else
Result := wvWin98;
90:
if (versionInfo.dwBuildNumber = 73010104) then
Result := wvWinME;
else
Result := wvWin9x;
end; //case versionInfo.dwMinorVersion
VER_PLATFORM_WIN32_NT:
case versionInfo.dwMajorVersion of
3: Result := wvWinNT3;
4: Result := wvWinNT4;
5:
case versionInfo.dwMinorVersion of
0: Result := wvWin2000;
1: Result := wvWinXP;
2: Result := wvWinServer2003;
else Result := wvWinNT
end; //case versionInfo.dwMinorVersion
6: Result := wvWinVista;
end; //case versionInfo.dwMajorVersion
end; //versionInfo.dwPlatformID
end; { DSiGetWindowsVersion }
{:Initializes font to the metrics of a specific GUI element.
@author aoven
@since 2007-11-13
}
function DSiInitFontToSystemDefault(aFont: TFont; aElement: TDSiUIElement): boolean;
var
NCM: TNonClientMetrics;
PLF: PLogFont;
begin
Result := false;
NCM.cbSize := SizeOf(TNonClientMetrics);
if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0) then begin
case aElement of
ueMenu: PLF := @NCM.lfMenuFont;
ueMessage: PLF := @NCM.lfMessageFont;
ueWindowCaption: PLF := @NCM.lfCaptionFont;
ueStatus: PLF := @NCM.lfStatusFont;
else raise Exception.Create('Unexpected GUI element');
end;
aFont.Handle := CreateFontIndirect(PLF^);
Result := true;
end;
end; { DSiInitFontToSystemDefault }
{:Returns True if the application is running with admin privileges.
Always returns True on Windows 95/98.
Based on http://www.gumpi.com/Blog/2007/10/02/EKON11PromisedEntry3.aspx.
@author gabr
@since 2002-11-25
}
function DSiIsAdmin: boolean;
var
accessToken : THandle;
administrators: PSID;
groups : PTokenGroups;
iGroup : integer;
infoBufferSize: DWORD;
success : BOOL;
begin
if not DSiIsWinNT then
Result := true
else begin
Result := false;
success := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, accessToken);
if not success then
if GetLastError = ERROR_NO_TOKEN then
success := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, accessToken);
if success then begin
if GetTokenInformation(accessToken, TokenGroups, nil, 0, infoBufferSize) or
(GetLastError <> ERROR_INSUFFICIENT_BUFFER)
then
RaiseLastOSError;
GetMem(groups, infoBufferSize);
success := GetTokenInformation(accessToken, TokenGroups, groups, infoBufferSize, infoBufferSize);
CloseHandle(accessToken);
if success then begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, administrators);
{$R-}
for iGroup := 0 to groups.GroupCount - 1 do begin
if EqualSid(administrators, groups.Groups[iGroup].Sid) then begin
Result := true;
break; //for iGroup
end;
end; //for iGroup
{$R+}
FreeSid(administrators);
end;
FreeMem(groups);
end;
end;
end; { DSiIsAdmin }
{:Returns True if an administrator is logged onto the system. Always returns True on
Windows 95/98.
@author Miha-R, gabr
@since 2002-11-25
}
function DSiIsAdminLoggedOn: boolean;
var
hSC: SC_HANDLE;
begin
if not DSiIsWinNT then
Result := true
else begin
// try an admin privileged API
hSC := DSiOpenSCManager(nil, nil,
GENERIC_READ or GENERIC_WRITE or GENERIC_EXECUTE);
Result := (hSC <> 0);
if Result then
DSiCloseServiceHandle(hSC);
end;
end; { DSiIsAdminLoggedOn }
{:Checks if disk is inserted in the specified drive.
@author Odisej
@since 2003-10-09
}
function DSiIsDiskInDrive(disk: char): boolean;
var
errorMode: word;
begin
errorMode := SetErrorMode(SEM_FailCriticalErrors);
try
Result := (DiskSize(Ord(disk) - Ord('A') + 1) >= 0);
finally SetErrorMode(errorMode); end;
end; { DSiIsDiskInDrive }
{:Checks if program is running on an NT platform.
@author Lee_Nover
@since 2002-11-25
}
function DSiIsWinNT: boolean;
begin
Result := (Win32Platform = VER_PLATFORM_WIN32_NT);
end; { DSiIsWinNT }
{:WOW64 is the x86 emulator that allows 32-bit Windows-based applications to run on
64-bit Windows. A 32-bit application can detect whether it is running under WOW64 by
calling the IsWow64Process function.
@author Miha-R, gabr
@since 2007-02-11
}
function DSiIsWow64: boolean;
var
isWow64: BOOL;
begin
Result := DSiIsWow64Process(GetCurrentProcess, isWow64);
if Result then
Result := isWow64;
end; { DSiIsWow64 }
{ Install }
function UninstallRoot: HKEY;
begin
if DSiIsWinNT then
Result := HKEY_CURRENT_USER
else
Result := HKEY_LOCAL_MACHINE;
end; { UninstallRoot }
{gp}
function DSiAddUninstallInfo(const displayName, uninstallCommand, publisher,
URLInfoAbout, displayVersion, helpLink, URLUpdateInfo: string): boolean;
begin
Result := false;
with TRegistry.Create do try
RootKey := UninstallRoot;
if OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\'+displayName, true) then
try
WriteString('DisplayName', displayName);
WriteString('UninstallString', uninstallCommand);
if publisher <> '' then
WriteString('Publisher', publisher);
if URLInfoAbout <> '' then
WriteString('URLInfoAbout', URLInfoAbout);
if displayVersion <> '' then
WriteString('DisplayVersion', displayVersion);
if helpLink <> '' then
WriteString('HelpLink', helpLink);
if URLUpdateInfo <> '' then
WriteString('URLUpdateInfo', URLUpdateInfo);
Result := true;
finally CloseKey; end;
finally {TRegistry.}Free; end;
end; { DSiAddUninstallInfo }
{ln}
function DSiAutoRunApp(const applicationName, applicationPath: string;
enabled: boolean): boolean;
begin
Result := false;
with TRegistry.Create do try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run', true) then try
if enabled then
WriteString(applicationName, applicationPath)
else
DeleteValue(applicationname);
Result:=true;
finally CloseKey; end;
finally {TRegistry.}Free; end;
end; { DSiAutoRunApp }
{gp}
// stolen from RXLib
procedure DSiCreateShortcut(const fileName, displayName, parameters: string;
folder: integer; const workDir: string);
var
fileDestPath: array [0..MAX_PATH] of char;
itemIDList : PItemIDList;
persistFile : IPersistFile;
shellLink : IShellLink;
{$IFNDEF Unicode}
fileNameW : array [0..MAX_PATH] of WideChar;
{$ENDIF}
begin
CoInitialize(nil);
try
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER,
IID_IShellLinkA, shellLink));
OleCheck(shellLink.QueryInterface(IID_IPersistFile, persistFile));
OleCheck(SHGetSpecialFolderLocation(0, folder, itemIDList));
SHGetPathFromIDList(itemIDList, fileDestPath);
StrCat(fileDestPath, PChar('\' + displayName + CLinkExt));
shellLink.SetPath(PChar(fileName));
shellLink.SetIconLocation(PChar(fileName), 0);
shellLink.SetWorkingDirectory(PChar(workDir));
shellLink.SetArguments(PChar(parameters));
{$IFDEF Unicode}
OleCheck(persistFile.Save(fileDestPath, true));
{$ELSE}
MultiByteToWideChar(CP_ACP, 0, fileDestPath, -1, fileNameW, MAX_PATH);
OleCheck(persistFile.Save(fileNameW, true));
{$ENDIF Unicode}
finally CoUninitialize; end;
end; { DSiCreateShortcut }
{gp}
function DSiDeleteShortcut(const displayName: string; folder: integer): boolean;
var
path: string;
begin
Result := false;
path := DSiGetFolderLocation(folder);
if path <> '' then begin
path := path + '\' + displayName + CLinkExt;
Result := DSiKillFile(path);
end;
end; { DSiDeleteShortcut }
{:Edits shortcut info.
@author Fora
@since 2006-06-20
}
procedure DSiEditShortcut(const lnkName, fileName, workDir, parameters: string);
var
persistFile: IPersistFile;
shellLink : IShellLink;
{$IFNDEF Unicode}
fileNameW : array [0..MAX_PATH] of WideChar;
{$ENDIF}
begin
CoInitialize(nil);
try
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER, IID_IShellLinkA, shellLink));
OleCheck(shellLink.QueryInterface(IID_IPersistFile, persistFile));
if (shellLink as IPersistFile).Load(PWideChar(WideString(lnkName)), 0) = 0 then
begin
shellLink.SetPath(PChar(fileName));
shellLink.SetWorkingDirectory(PChar(workDir));
shellLink.SetArguments(PChar(parameters));
{$IFDEF Unicode}
OleCheck(persistFile.Save(PChar(lnkName), true));
{$ELSE}
MultiByteToWideChar(CP_ACP, 0, PChar(lnkName), -1, fileNameW, MAX_PATH);
OleCheck(persistFile.Save(fileNameW, true));
{$ENDIF Unicode}
end;
finally CoUninitialize; end;
end; { DSiEditShortcut }
{:Extracts executable path and work dir from the LNK file.
@author Cavlji
@since 2006-06-20
}
function DSiGetShortcutInfo(const lnkName: string; var fileName, filePath, workDir,
parameters: string): boolean;
var
buf : array [0..MAX_PATH] of char;
param : array[0..MAX_PATH] of char;
findData : TWin32FindData;
shellLink: IShellLink;
begin
CoInitialize(nil);
try
Result := false;
OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER, IID_IShellLinkA,
shellLink));
if (shellLink as IPersistFile).Load(PWideChar(WideString(lnkName)), 0) = 0 then begin
shellLink.GetPath(buf, MAX_PATH, findData, 0);
fileName := findData.cFileName;
filePath := buf;
shellLink.GetWorkingDirectory(buf, MAX_PATH);
shellLink.GetArguments(param, MAX_PATH);
parameters := param;
workDir := buf;
Result := true;
end;
finally CoUninitialize; end;
end; { DSiGetShortcutInfo }
{gp}
function DSiGetUninstallInfo(const displayName: string;
out uninstallCommand: string): boolean;
begin
uninstallCommand :=
DSiReadRegistry('\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\'+displayName,
'UninstallString', '', UninstallRoot);
Result := (uninstallCommand <> '');
end; { DSiGetUninstallInfo }
{ln}
function DSiIsAutoRunApp(const applicationname: string): boolean;
begin
Result :=
(DSiReadRegistry('\Software\Microsoft\Windows\CurrentVersion\Run', applicationname, '') <> '');
end; { DSiIsAutoRunApp }
{ln}
function DSiRegisterActiveX(const fileName: string;
registerDLL: boolean): HRESULT;
type
TDLLRegisterServer = function: HResult; stdcall;
var
_Register: TDllRegisterServer;
DLLHandle: THandle;
begin
Result := E_FAIL;
DLLHandle := LoadLibrary(PChar(FileName));
if DLLHandle > 0 then
try
if RegisterDLL then
_Register := GetProcAddress(DLLHandle, 'DllRegisterServer')
else
_Register := GetProcAddress(DLLHandle, 'DllUnregisterServer');
if Assigned(_Register) then
Result := _Register
else
Result := E_NOTIMPL;
finally FreeLibrary(DLLHandle); end;
end; { DSiRegisterActiveX }
{gp}
procedure DSiRegisterRunOnce(const applicationName, applicationPath: string);
begin
DSiWriteRegistry('SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce',
applicationName, applicationPath);
end; { DSiRegisterRunOnce }
{gp}
procedure DSiRemoveRunOnce(const applicationName: string);
begin
with TRegistry.Create do try
RootKey := HKEY_CURRENT_USER;
if OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce', true) then try
DeleteValue(applicationName);
finally CloseKey; end;
finally {TRegistry.}Free; end;
end; { DSiRemoveRunOnce }
{gp}
function DSiRemoveUninstallInfo(const displayName: string): boolean;
begin
Result :=
DSiKillRegistry('\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\'+displayName,
UninstallRoot);
end; { DSiRemoveUninstallInfo }
{gp}
function DSiShortcutExists(const displayName: string; folder: integer): boolean;
var
path: string;
begin
path := DSiGetFolderLocation(folder);
if path <> '' then begin
path := path + '\' + displayName + CLinkExt;
Result := FileExists(path);
end
else
Result := false;
end; { DSiShortcutExists }
{ Time }
threadvar
GLastTimeGetTime : DWORD;
GTimeGetTimeBase : int64;
var
GPerformanceFrequency: int64;
constructor TDSiTimer.Create(enabled: boolean; interval: cardinal; onTimer: TNotifyEvent;
tag: longint);
begin
inherited Create;
dtEnabled := enabled;
dtInterval := interval;
dtOnTimer := onTimer;
dtTag := tag;
dtWindowHandle := DSiAllocateHWnd(WndProc);
UpdateTimer;
end; { TDSiTimer.Create }
destructor TDSiTimer.Destroy;
begin
dtEnabled := false;
UpdateTimer;
DSiDeallocateHWnd(dtWindowHandle);
inherited;
end; { TDSiTimer.Destroy }
procedure TDSiTimer.SetEnabled(value: boolean);
begin
if value <> dtEnabled then begin
dtEnabled := value;
UpdateTimer;
end;
end; { TDSiTimer.SetEnabled }
procedure TDSiTimer.SetInterval(value: cardinal);
begin
if value <> dtInterval then begin
dtInterval := value;
UpdateTimer;
end;
end; { TDSiTimer.SetInterval }
procedure TDSiTimer.SetOnTimer(value: TNotifyEvent);
begin
dtOnTimer := value;
UpdateTimer;
end; { TDSiTimer.SetOnTimer }
procedure TDSiTimer.UpdateTimer;
begin
KillTimer(dtWindowHandle, 1);
if (Interval <> 0) and Enabled and Assigned(OnTimer) then
if SetTimer(dtWindowHandle, 1, Interval, nil) = 0 then
raise EOutOfResources.Create(SNoTimers);
end; { TDSiTimer.UpdateTimer }
procedure TDSiTimer.WndProc(var msgRec: TMessage);
begin
with msgRec do begin
if Msg = WM_TIMER then begin
if Assigned(OnTimer) then
OnTimer(Self);
end
else
Result := DefWindowProc(dtWindowHandle, Msg, wParam, lParam);
end; //with msgRec
end; { TDSiTimer.WndProc }
{gp}
function DSiElapsedSince(midTime, startTime: int64): int64;
begin
if midTime < startTime then
midTime := midTime + $100000000;
Result := midTime - startTime;
end; { TDSiRegistry.DSiElapsedSince }
{gp}
function DSiElapsedTime(startTime: int64): int64;
begin
Result := DSiElapsedSince(GetTickCount, startTime);
end; { DSiElapsedTime }
{:Converts time from Windows TFileTime format to Delphi TDateTime format.
@returns 0 if conversion failed.
@author gabr
@since 2006-12-20
}
function DSiFileTimeToDateTime(fileTime: TFileTime): TDateTime;
begin
if not DSiFileTimeToDateTime(fileTime, Result) then
Result := 0;
end; { DSiFileTimeToDateTime }
{:Converts time from Windows TFileTime format to Delphi TDateTime format.
@returns false if conversion failed.
@author gabr
@since 2006-12-20
}
function DSiFileTimeToDateTime(fileTime: TFileTime; var dateTime: TDateTime): boolean;
var
sysTime: TSystemTime;
begin
Result := FileTimeToSystemTime(fileTime, sysTime);
if Result then
dateTime := SystemTimeToDateTime(sysTime);
end; { DSiFileTimeToDateTime }
{:Converts TFileTime structure containing nanoseconds (user and kernel time returned
from GetProcessTimes, for example) into int64 containing microseconds.
@since 2006-12-20
}
function DSiFileTimeToMicroSeconds(fileTime: TFileTime): int64;
begin
Int64Rec(Result).Lo := fileTime.dwLowDateTime;
Int64Rec(Result).Hi := fileTime.dwHighDateTime;
Result := Result div 10;
end; { DSiFileTimeToMicroSeconds }
{gp}
function DSiHasElapsed(startTime: int64; timeout: DWORD): boolean;
begin
if timeout = 0 then
Result := true
else if timeout = INFINITE then
Result := false
else
Result := (DSiElapsedTime(startTime) > timeout);
end; { DSiHasElapsed }
{:Converts value returned from QueryPerformanceCounter to milliseconds.
@author gabr
@since 2007-12-03
}
function DSiPerfCounterToMS(perfCounter: int64): int64;
begin
Result := 0;
if GPerformanceFrequency > 0 then
Result := Round(perfCounter / GPerformanceFrequency * 1000);
end; { DSiPerfCounterToMS }
{:Converts value returned from QueryPerformanceCounter to microseconds.
@author gabr
@since 2007-12-03
}
function DSiPerfCounterToUS(perfCounter: int64): int64;
begin
Result := 0;
if GPerformanceFrequency > 0 then
Result := Round(perfCounter / GPerformanceFrequency * 1000000);
end; { DSiPerfCounterToUS }
{:Calls QueryPerformanceCounter and returns the result as microseconds.
@author gabr
@since 2007-12-03
}
function DSiQueryPerfCounterAsUS: int64;
begin
if QueryPerformanceCounter(Result) then
Result := DSiPerfCounterToUS(Result)
else
Result := 0;
end; { DSiQueryPerfCounterAsUS }
{:64-bit extension of MM timeGetTime. Time units are milliseconds.
@author gabr
@since 2007-11-26
}
function DSiTimeGetTime64: int64;
begin
Result := timeGetTime;
if Result < GLastTimeGetTime then
GTimeGetTimeBase := GTimeGetTimeBase + $100000000;
GLastTimeGetTime := Result;
Result := Result + GTimeGetTimeBase;
end; { DSiTimeGetTime64 }
{ales, Brdaws}
//'delay' is in microseconds
procedure DSiuSecDelay(delay: int64);
var
dif : int64;
endTime: TLargeInteger;
freq : TLargeInteger;
nowTime: TLargeInteger;
begin
QueryPerformanceFrequency(freq);
dif := delay * freq div 1000000;
QueryPerformanceCounter(endTime);
endTime := endTime + dif;
repeat
QueryPerformanceCounter(nowTime);
until nowTime >= endTime;
end; { DSiuSecDelay }
{ Interlocked }
function DSiInterlockedDecrement64(var addend: int64): int64; register;
asm
{ -> EAX addend }
{ <- EDX:EAX Result }
PUSH EDI
PUSH EBX
MOV EDI, EAX
MOV EAX, [EDI] // Fetch original int64 at memory location
MOV EDX, [EDI+4]
@@1:
MOV ECX, EDX
MOV EBX, EAX
SUB EBX, 1
SBB ECX, 0
LOCK CMPXCHG8B [EDI]
JNZ @@1
{ Returns updated value of addend }
MOV EAX, EBX
MOV EDX, ECX
POP EBX
POP EDI
end; { DSiInterlockedDecrement64 }
function DSiInterlockedIncrement64(var addend: int64): int64; register;
asm
{ -> EAX addend }
{ <- EDX:EAX Result }
PUSH EDI
PUSH EBX
MOV EDI, EAX
MOV EAX, [EDI] // Fetch original int64 at memory location
MOV EDX, [EDI+4]
@@1:
MOV ECX, EDX
MOV EBX, EAX
ADD EBX, 1
ADC ECX, 0
LOCK CMPXCHG8B [EDI]
JNZ @@1
{ Returns updated value of addend }
MOV EAX, EBX
MOV EDX, ECX
POP EBX
POP EDI
end; { DSiInterlockedIncrement64 }
function DSiInterlockedExchangeAdd64(var addend: int64; value: int64): int64; register;
asm
{ -> EAX addend }
{ ESP+4 value }
{ <- EDX:EAX Result }
PUSH EDI
PUSH ESI
PUSH EBP
PUSH EBX
MOV ESI, DWORD PTR [value] // EDI:ESI = value
MOV EDI, DWORD PTR [value+4]
MOV EBP, EAX
MOV EAX, [EBP] // EDX:EAX = addend (fetch original int64 value)
MOV EDX, [EBP+4]
@@1:
MOV ECX, EDX // ECX:EBX = addend
MOV EBX, EAX
ADD EBX, ESI
ADC ECX, EDI
LOCK CMPXCHG8B [EBP]
JNZ @@1
// Returns initial value in addend
POP EBX
POP EBP
POP ESI
POP EDI
end; { DSiInterlockedExchangeAdd64 }
function DSiInterlockedExchange64(var target: int64; value: int64): int64; register;
asm
{ -> EAX target }
{ ESP+4 value }
{ <- EDX:EAX Result }
PUSH EDI
PUSH EBX
MOV EDI, EAX
MOV EAX, [EDI]
MOV EDX, [EDI+4]
MOV EBX, DWORD PTR [value]
MOV ECX, DWORD PTR [value+4]
@@1:
LOCK CMPXCHG8B [EDI]
JNZ @@1
// Returns initial value in target
POP EBX
POP EDI
end; { DSiInterlockedExchange64 }
function DSiInterlockedCompareExchange64(var destination: int64; exchange, comparand: int64): int64; register;
asm
{ -> EAX destination }
{ ESP+4 exchange }
{ ESP+12 comparand }
{ <- EDX:EAX Result }
PUSH EBX
PUSH EDI
MOV EDI, EAX
MOV EAX, DWORD PTR [comparand]
MOV EDX, DWORD PTR [comparand+4]
MOV EBX, DWORD PTR [exchange]
MOV ECX, DWORD PTR [exchange+4]
LOCK CMPXCHG8B [EDI]
POP EDI
POP EBX
end; { DSiInterlockedCompareExchange64 }
function DSiInterlockedCompareExchange64(destination: PInt64; exchange, comparand: int64): int64; register;
asm
{ -> EAX destination }
{ ESP+4 exchange }
{ ESP+12 comparand }
{ <- EDX:EAX Result }
PUSH EBX
PUSH EDI
MOV EDI, EAX
MOV EAX, DWORD PTR [comparand]
MOV EDX, DWORD PTR [comparand+4]
MOV EBX, DWORD PTR [exchange]
MOV ECX, DWORD PTR [exchange+4]
LOCK CMPXCHG8B [EDI]
POP EDI
POP EBX
end; { DSiInterlockedCompareExchange64 }
{ DynaLoad }
var
_GLibraryList: TStringList = nil;
function GLibraryList: TStringList;
begin
if not assigned(_GLibraryList) then
_GLibraryList := TStringList.Create;
Result := _GLibraryList;
end; { GLibraryList }
{:Loads library and adds library handle to the list of handles that must be
unloaded at process termination. Caches library handle for future reference.
@since 2003-09-02
}
function DSiLoadLibrary(const libFileName: string): HMODULE;
var
hLib : HMODULE;
idxLib: integer;
begin
idxLib := GLibraryList.IndexOf(libFileName);
if idxLib < 0 then begin
hLib := LoadLibrary(PChar(libFileName));
if hLib <> 0 then
idxLib := GLibraryList.AddObject(libFileName, TObject(hLib));
end;
if idxLib >= 0 then
Result := HMODULE(GLibraryList.Objects[idxLib])
else
Result := 0;
end; { DSiLoadLibrary }
{:Loads the library if it was not loaded yet (and adds it to the list of
libraries that must be unloaded at process termination), then calls
GetProcAddress.
@since 2003-09-02
}
function DSiGetProcAddress(const libFileName, procName: string): FARPROC;
begin
Result := GetProcAddress(DSiLoadLibrary(libFileName), PChar(procName));
end; { DSiGetProcAddress }
{:Unloads all loaded libraries.
@since 2003-09-02
}
procedure DSiUnloadLibrary;
var
iLib: integer;
begin
for iLib := 0 to GLibraryList.Count-1 do
if HMODULE(GLibraryList.Objects[iLib]) <> 0 then begin
FreeLibrary(HMODULE(GLibraryList.Objects[iLib]));
GLibraryList.Objects[iLib] := TObject(0);
end;
end; { TDSiRegistry.DSiUnloadLibrary }
function DSi9xNetShareAdd(serverName: PChar; shareLevel: smallint;
buffer: pointer; size: word): integer;
begin
if not assigned(G9xNetShareAdd) then
G9xNetShareAdd := DSiGetProcAddress('svrapi.dll', 'NetShareAdd');
if assigned(G9xNetShareAdd) then
Result := G9xNetShareAdd(serverName, shareLevel, buffer, size)
else
Result := ERROR_NOT_SUPPORTED;
end; { DSi9xNetShareAdd }
function DSi9xNetShareDel(serverName: PChar; netName: PChar;
reserved: word): integer;
begin
if not assigned(G9xNetShareDel) then
G9xNetShareDel := DSiGetProcAddress('svrapi.dll', 'NetShareDel');
if assigned(G9xNetShareDel) then
Result := G9xNetShareDel(serverName, netName, reserved)
else
Result := ERROR_NOT_SUPPORTED;
end; { DSi9xNetShareDel }
function DSiCloseServiceHandle(hSCObject: SC_HANDLE): BOOL;
begin
if not assigned(GCloseServiceHandle) then
GCloseServiceHandle := DSiGetProcAddress('advapi32.dll',
'CloseServiceHandle');
if assigned(GCloseServiceHandle) then
Result := GCloseServiceHandle(hSCObject)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
end; { DSiCloseServiceHandle }
function DSiCreateProcessAsUser(hToken: THandle;
lpApplicationName, lpCommandLine: PChar; lpProcessAttributes,
lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL;
dwCreationFlags: DWORD; lpEnvironment: pointer;
lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
var lpProcessInformation: TProcessInformation): BOOL;
begin
{$IFDEF Unicode} //Tiburon defines CreateProcessAsUser
Result := CreateProcessAsUser(hToken, lpApplicationName, lpCommandLine,
lpProcessAttributes, lpThreadAttributes, bInheritHandles,
dwCreationFlags, lpEnvironment, lpCurrentDirectory, lpStartupInfo,
lpProcessInformation);
{$ELSE}
if not assigned(GCreateProcessAsUser) then
GCreateProcessAsUser := DSiGetProcAddress('advapi32.dll',
'CreateProcessAsUserA');
if assigned(GCreateProcessAsUser) then
Result := GCreateProcessAsUser(hToken, lpApplicationName, lpCommandLine,
lpProcessAttributes, lpThreadAttributes, bInheritHandles,
dwCreationFlags, lpEnvironment, lpCurrentDirectory, lpStartupInfo,
lpProcessInformation)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
{$ENDIF Unicode}
end; { DSiCreateProcessAsUser }
//http://msdn2.microsoft.com/en-us/library/aa969510.aspx
function DSiDwmEnableComposition(uCompositionAction: UINT): HRESULT;
begin
if not assigned(GDwmEnableComposition) then
GDwmEnableComposition := DSiGetProcAddress('DWMAPI.dll', 'DwmEnableComposition');
if assigned(GDwmEnableComposition) then
Result := GDwmEnableComposition(uCompositionAction)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := S_FALSE;
end;
end; { DSiDwmEnableComposition }
//http://msdn2.microsoft.com/en-us/library/aa969518.aspx
function DSiDwmIsCompositionEnabled(var pfEnabled: BOOL): HRESULT; stdcall;
begin
if not assigned(GDwmIsCompositionEnabled) then
GDwmIsCompositionEnabled := DSiGetProcAddress('DWMAPI.dll', 'DwmIsCompositionEnabled');
if assigned(GDwmIsCompositionEnabled) then
Result := GDwmIsCompositionEnabled(pfEnabled)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := S_FALSE;
end;
end; { DSiDwmIsCompositionEnabled }
function DSiEnumProcessModules(hProcess: THandle; lphModule: PModule; cb: DWORD;
var lpcbNeeded: DWORD): BOOL; stdcall;
begin
if not assigned(GEnumProcessModules) then
GEnumProcessModules := DSiGetProcAddress('psapi.dll', 'EnumProcessModules');
if assigned(GEnumProcessModules) then
Result := GEnumProcessModules(hProcess, lphModule, cb, lpcbNeeded)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
end; { DSiEnumProcessModules }
function DSiGetModuleFileNameEx(hProcess: THandle; hModule: HMODULE; lpFilename: PChar;
nSize: DWORD): DWORD; stdcall;
begin
if not assigned(GGetModuleFileNameEx) then
GGetModuleFileNameEx := DSiGetProcAddress('psapi.dll', 'GetModuleFileNameExA');
if assigned(GGetModuleFileNameEx) then
Result := GGetModuleFileNameEx(hProcess, hModule, lpFilename, nSize)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := 0;
end;
end; { DSiGetModuleFileNameEx }
function DSiGetProcessImageFileName(hProcess: THandle; lpImageFileName: PChar;
nSize: DWORD): DWORD; stdcall;
begin
if not assigned(GGetProcessImageFileName) then
GGetProcessImageFileName := DSiGetProcAddress('psapi.dll', 'GetProcessImageFileNameA');
if assigned(GGetProcessImageFileName) then
Result := GGetProcessImageFileName(hProcess, lpImageFileName, nSize)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := 0;
end;
end; { DSiGetProcessImageFileName }
{:Retrieves application compatibility flags for the specified application.
@since 2007-02-11
@author Miha-R, gabr
}
function DSiGetProcessMemoryInfo(process: THandle; memCounters: PProcessMemoryCounters;
cb: DWORD): boolean; stdcall;
begin
if not assigned(GGetProcessMemoryInfo) then
GGetProcessMemoryInfo := DSiGetProcAddress('psapi.dll', 'GetProcessMemoryInfo');
if assigned(GGetProcessMemoryInfo) then
Result := GGetProcessMemoryInfo(process, memCounters, cb)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
end; { DSiGetProcessMemoryInfo }
function DSiImpersonateLoggedOnUser(hToken: THandle): BOOL; stdcall;
begin
if not assigned(GImpersonateLoggedOnUser) then
GImpersonateLoggedOnUser := DSiGetProcAddress('advapi32.dll',
'ImpersonateLoggedOnUser');
if assigned(GImpersonateLoggedOnUser) then
Result := GImpersonateLoggedOnUser(hToken)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
end; { DSiImpersonateLoggedOnUser }
function DSiIsWow64Process(hProcess: THandle; var wow64Process: BOOL): BOOL; stdcall;
begin
if not assigned(GIsWow64Process) then
GIsWow64Process := DSiGetProcAddress('kernel32', 'IsWow64Process');
if assigned(GIsWow64Process) then
Result := GIsWow64Process(hProcess, wow64Process)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
end; { DSiIsWow64Process }
function DSiLogonUser(lpszUsername, lpszDomain, lpszPassword: PChar;
dwLogonType, dwLogonProvider: DWORD; var phToken: THandle): BOOL;
begin
{$IFDEF Unicode} //Tiburon defines LogonUser
Result := LogonUser(lpszUsername, lpszDomain, lpszPassword, dwLogonType,
dwLogonProvider, phToken);
{$ELSE}
Result := false;
if not assigned(GLogonUser) then
GLogonUser := DSiGetProcAddress('advapi32.dll', 'LogonUserA');
if assigned(GLogonUser) then begin
if not DSiEnablePrivilege('SeTcbName') and DSiEnablePrivilege('SeChangeNotifyName')
then
Exit;
Result := GLogonUser(lpszUsername, lpszDomain, lpszPassword, dwLogonType,
dwLogonProvider, phToken)
end
else
SetLastError(ERROR_NOT_SUPPORTED);
{$ENDIF Unicode}
end; { DSiLogonUser }
function DSiNetApiBufferFree(buffer: pointer): cardinal; stdcall;
begin
if not assigned(GNetApiBufferFree) then
GNetApiBufferFree := DSiGetProcAddress('netapi32.dll', 'NetWkstaGetInfo');
if assigned(GNetApiBufferFree) then
Result := GNetApiBufferFree(buffer)
else
Result := ERROR_NOT_SUPPORTED;
end; { DSiNetApiBufferFree }
function DSiNetWkstaGetInfo(servername: PChar; level: cardinal;
out bufptr: Pointer): cardinal; stdcall;
begin
if not assigned(GNetWkstaGetInfo) then
GNetWkstaGetInfo := DSiGetProcAddress('netapi32.dll', 'NetWkstaGetInfo');
if assigned(GNetWkstaGetInfo) then
Result := GNetWkstaGetInfo(servername, level, bufptr)
else
Result := ERROR_NOT_SUPPORTED;
end; { DSiNetWkstaGetInfo }
function DSiNTNetShareAdd(serverName: PChar; level: integer; buf: PChar;
var parm_err: integer): DWord;
begin
if not assigned(GNTNetShareAdd) then
GNTNetShareAdd := DSiGetProcAddress('netapi32.dll', 'NetShareAdd');
if assigned(GNTNetShareAdd) then
Result := GNTNetShareAdd(serverName, level, buf, parm_err)
else
Result := ERROR_NOT_SUPPORTED;
end; { DSiNTNetShareAdd }
function DSiNTNetShareDel(serverName: PChar; netName: PWideChar;
reserved: integer): DWord;
begin
if not assigned(GNTNetShareDel) then
GNTNetShareDel := DSiGetProcAddress('netapi32.dll', 'NetShareDel');
if assigned(GNTNetShareDel) then
Result := GNTNetShareDel(serverName, netName, reserved)
else
Result := ERROR_NOT_SUPPORTED;
end; { DSiNTNetShareDel }
function DSiOpenSCManager(lpMachineName, lpDatabaseName: PChar;
dwDesiredAccess: DWORD): SC_HANDLE; stdcall;
begin
if not assigned(GOpenSCManager) then
GOpenSCManager := DSiGetProcAddress('advapi32.dll', 'OpenSCManagerA');
if assigned(GOpenSCManager) then
Result := GOpenSCManager(lpMachineName, lpDatabaseName, dwDesiredAccess)
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := 0;
end;
end; { DSiOpenSCManager }
function DSiRevertToSelf: BOOL; stdcall;
begin
if not assigned(GRevertToSelf) then
GRevertToSelf := DSiGetProcAddress('advapi32.dll', 'RevertToSelf');
if assigned(GRevertToSelf) then
Result := GRevertToSelf
else begin
SetLastError(ERROR_NOT_SUPPORTED);
Result := false;
end;
end; { DSiRevertToSelf }
function DSiSetDllDirectory(path: PChar): boolean; stdcall;
begin
if not assigned(GSetDllDirectory) then
GSetDllDirectory := DSiGetProcAddress('kernel32.dll', 'SetDllDirectoryA');
if assigned(GSetDllDirectory) then
Result := GSetDllDirectory(path)
else
Result := false;
end; { DSiSetDllDirectory }
function DSiSetSuspendState(hibernate, forceCritical, disableWakeEvent: BOOL): BOOL; stdcall;
begin
if not assigned(GSetSuspendState) then
GSetSuspendState := DSiGetProcAddress('PowrProf.dll', 'SetSuspendState');
if assigned(GSetSuspendState) then
Result := GSetSuspendState(hibernate, forceCritical, disableWakeEvent)
else
Result := false;
end; { DSiSetSuspendState }
function DSiSHEmptyRecycleBin(Wnd: HWND; pszRootPath: PChar;
dwFlags: DWORD): HRESULT; stdcall;
begin
if not assigned(GSHEmptyRecycleBin) then
GSHEmptyRecycleBin := DSiGetProcAddress('shell32.dll',
'SHEmptyRecycleBinA');
if assigned(GSHEmptyRecycleBin) then
Result := GSHEmptyRecycleBin(Wnd, pszRootPath, dwFlags)
else
Result := S_FALSE;
end; { DSiSHEmptyRecycleBin }
initialization
InitializeCriticalSection(GDSiWndHandlerCritSect);
GDSiWndHandlerCount := 0;
GTimeGetTimeBase := 0;
GLastTimeGetTime := 0;
if not QueryPerformanceFrequency(GPerformanceFrequency) then
GPerformanceFrequency := 0;
GCF_HTML := RegisterClipboardFormat('HTML Format');
timeBeginPeriod(1);
finalization
timeEndPeriod(1);
DeleteCriticalSection(GDSiWndHandlerCritSect);
DSiUnloadLibrary;
FreeAndNil(_GLibraryList);
end.