{******************************************************************************}
{ }
{ Project JEDI Code Library (JCL) }
{ }
{ The contents of this file are subject to the Mozilla Public License Version }
{ 1.1 (the "License"); you may not use this file except in compliance with the }
{ License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ }
{ }
{ Software distributed under the License is distributed on an "AS IS" basis, }
{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }
{ the specific language governing rights and limitations under the License. }
{ }
{ The Original Code is JclSysInfo.pas. }
{ }
{ The Initial Developer of the Original Code is documented in the accompanying }
{ help file JCL.chm. Portions created by these individuals are Copyright (C) }
{ of these individuals. }
{ }
{******************************************************************************}
{ }
{ This unit contains routines and classes to retrieve various pieces of system }
{ information. Examples are the location of standard folders, settings of }
{ environment variables, processor details and the Windows version. }
{ }
{ Unit owner: Eric S. Fisher }
{ Last modified: November 18, 2001 }
{ }
{******************************************************************************}
unit JclSysInfo;
{$I jcl.inc}
interface
uses
Windows, ActiveX, Classes, ShlObj,
JclResources;
//------------------------------------------------------------------------------
// Environment Variables
//------------------------------------------------------------------------------
type
TEnvironmentOption = (eoLocalMachine, eoCurrentUser, eoAdditional);
TEnvironmentOptions = set of TEnvironmentOption;
function DelEnvironmentVar(const Name: string): Boolean;
function ExpandEnvironmentVar(var Value: string): Boolean;
function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
function SetEnvironmentVar(const Name, Value: string): Boolean;
function CreateEnvironmentBlock(const Options: TEnvironmentOptions;
const AdditionalVars: TStrings): PChar;
//------------------------------------------------------------------------------
// Common Folder Locations
//------------------------------------------------------------------------------
function GetCommonFilesFolder: string;
function GetCurrentFolder: string;
function GetProgramFilesFolder: string;
function GetWindowsFolder: string;
function GetWindowsSystemFolder: string;
function GetWindowsTempFolder: string;
function GetDesktopFolder: string;
function GetProgramsFolder: string;
function GetPersonalFolder: string;
function GetFavoritesFolder: string;
function GetStartupFolder: string;
function GetRecentFolder: string;
function GetSendToFolder: string;
function GetStartmenuFolder: string;
function GetDesktopDirectoryFolder: string;
function GetNethoodFolder: string;
function GetFontsFolder: string;
function GetCommonStartmenuFolder: string;
function GetCommonProgramsFolder: string;
function GetCommonStartupFolder: string;
function GetCommonDesktopdirectoryFolder: string;
function GetAppdataFolder: string;
function GetPrinthoodFolder: string;
function GetCommonFavoritesFolder: string;
function GetTemplatesFolder: string;
function GetInternetCacheFolder: string;
function GetCookiesFolder: string;
function GetHistoryFolder: string;
//------------------------------------------------------------------------------
// Advanced Power Management (APM)
//------------------------------------------------------------------------------
type
TAPMLineStatus = (alsOffline, alsOnline, alsUnknown);
TAPMBatteryFlag = (abfHigh, abfLow, abfCritical, abfCharging, abfNoBattery, abfUnknown);
function GetAPMLineStatus: TAPMLineStatus;
function GetAPMBatteryFlag: TAPMBatteryFlag;
function GetAPMBatteryLifePercent: Integer;
function GetAPMBatteryLifeTime: DWORD;
function GetAPMBatteryFullLifeTime: DWORD;
//------------------------------------------------------------------------------
// Identification
//------------------------------------------------------------------------------
function GetVolumeName(const Drive: string): string;
function GetVolumeSerialNumber(const Drive: string): string;
function GetVolumeFileSystem(const Drive: string): string;
function GetIPAddress(const HostName: string): string;
function GetLocalComputerName: string;
function GetLocalUserName: string;
function GetUserDomainName(const CurUser: string): string;
function GetDomainName: string;
function GetRegisteredCompany: string;
function GetRegisteredOwner: string;
function GetBIOSName: string;
function GetBIOSCopyright: string;
function GetBIOSExtendedInfo: string;
function GetBIOSDate: TDateTime;
//------------------------------------------------------------------------------
// Processes, Tasks and Modules
//------------------------------------------------------------------------------
type
TJclTerminateAppResult = (taError, taClean, taKill);
function RunningProcessesList(const List: TStrings; FullPath: Boolean {$IFDEF SUPPORTS_DEFAULTPARAMS} = True {$ENDIF}): Boolean;
function LoadedModulesList(const List: TStrings; ProcessID: DWORD): Boolean;
function GetTasksList(const List: TStrings): Boolean;
function IsWindowResponding(Wnd: HWND; Timeout: Integer): Boolean;
function GetWindowIcon(Wnd: HWND; LargeIcon: Boolean): HICON;
function TerminateTask(Wnd: HWND; Timeout: Integer): TJclTerminateAppResult;
function TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;
function GetPidFromProcessName(const ProcessName: string): DWORD;
function GetProcessNameFromWnd(Wnd: HWND): string;
function GetProcessNameFromPid(PID: DWORD): string;
function GetShellProcessName: string;
function GetShellProcessHandle: THandle;
//------------------------------------------------------------------------------
// Version Information
//------------------------------------------------------------------------------
type
TWindowsVersion = (wvUnknown, wvWin95, wvWin95OSR2, wvWin98, wvWin98SE,
wvWinME, wvWinNT3, wvWinNT4, wvWin2000, wvWinXP);
TNtProductType = (ptUnknown, ptWorkStation, ptServer, ptAdvancedServer,
ptPersonal, ptProfessional, ptDatacenterServer);
{ TODOC
Added to TNtProductType (by Jean-Fabien Connault):
ptPersonal Windows XP Personal
ptProfessional Windows 2000/XP Proffesional
ptDatacenterServer Windows 2000 DataCenter server
}
var
{ in case of additions, don't forget to update initialization section! }
IsWin95: Boolean = False;
IsWin95OSR2: Boolean = False;
IsWin98: Boolean = False;
IsWin98SE: Boolean = False;
IsWinME: Boolean = False;
IsWinNT: Boolean = False;
IsWinNT3: Boolean = False;
IsWinNT4: Boolean = False;
IsWin2K: Boolean = False;
IsWinXP: Boolean = False;
function GetWindowsVersion: TWindowsVersion;
function NtProductType: TNtProductType;
// TODOC
function GetWindowsVersionString: string;
{
ShortDescr: Returns the windows version as a string.
Descr: GetWindowsVersion returns the operating system as a string. For example, 'Windows 2000'.
Result: The windows version as a string or an empty string if the OS is not recognized.
Author: Jean-Fabien Connault
}
function NtProductTypeString: string;
{
ShortDescr: Returns the Windows NT product type as a string.
Descr: NtProductTypeString returns the NT product type as a string. For example 'Workstation'.
Result: The NT product type as a string or an empty string if the product type is not recognized.
Author: Jean-Fabien Connault
}
function GetWindowsServicePackVersion: Integer;
{
ShortDescr: Returns the installed service pack
Descr: Returns the major version number of the latest installed Windows Service Pack.
Result: The major version number of the latest installed Service Pack. In case of failure, or it
no Service Pack is installed, the function returns 0.
Author: Jean-Fabien Connault
}
//------------------------------------------------------------------------------
// Hardware
//------------------------------------------------------------------------------
function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;
function ReadTimeStampCounter: Int64;
type
TIntelSpecific = record
L2Cache: Cardinal;
CacheDescriptors: array [0..15] of Byte;
BrandID : Byte;
end;
TCyrixSpecific = record
L1CacheInfo: array [0..3] of Byte;
TLBInfo: array [0..3] of Byte;
end;
TAMDSpecific = record
DataTLB: array [0..1] of Byte;
InstructionTLB: array [0..1] of Byte;
L1DataCache: array [0..3] of Byte;
L1ICache: array [0..3] of Byte;
end;
TCacheInfo = record
D: Byte;
I: string;
end;
TFreqInfo = record
RawFreq: Cardinal;
NormFreq: Cardinal;
InCycles: Cardinal;
ExTicks: Cardinal;
end;
TCpuInfo = record
HasInstruction: Boolean;
MMX: Boolean;
IsFDIVOK: Boolean;
HasCacheInfo: Boolean;
HasExtendedInfo: Boolean;
CpuType: Byte;
PType: Byte;
Family: Byte;
Model: Byte;
Stepping: Byte;
Features: Cardinal;
FrequencyInfo: TFreqInfo;
VendorIDString: array [0..11] of Char;
Manufacturer: array [0..9] of Char;
CpuName: array [0..47] of Char;
IntelSpecific: TIntelSpecific;
CyrixSpecific: TCyrixSpecific;
AMDSpecific: TAMDSpecific;
end;
const
CPU_TYPE_INTEL = 1;
CPU_TYPE_CYRIX = 2;
CPU_TYPE_AMD = 3;
// Constants to be used with Feature Flag set of a CPU
// eg. IF (Features and FPU_FLAG = FPU_FLAG) THEN CPU has Floating-Point unit on
// chip. However, Intel claims that in future models, a zero in the feature
// flags will mean that the chip has that feature, however, the following flags
// will work for any production 80x86 chip or clone.
// eg. IF (Features and FPU_FLAG = 0) then CPU has Floating-Point unit on chip.
const
{ Standard (Intel) Feature Flags }
FPU_FLAG = $00000001; // Floating-Point unit on chip
VME_FLAG = $00000002; // Virtual Mode Extention
DE_FLAG = $00000004; // Debugging Extention
PSE_FLAG = $00000008; // Page Size Extention
TSC_FLAG = $00000010; // Time Stamp Counter
MSR_FLAG = $00000020; // Model Specific Registers
PAE_FLAG = $00000040; // Physical Address Extention
MCE_FLAG = $00000080; // Machine Check Exception
CX8_FLAG = $00000100; // CMPXCHG8 Instruction
APIC_FLAG = $00000200; // Software-accessible local APIC on Chip
BIT_10 = $00000400; // Reserved, do not count on value
SEP_FLAG = $00000800; // Fast System Call
MTRR_FLAG = $00001000; // Memory Type Range Registers
PGE_FLAG = $00002000; // Page Global Enable
MCA_FLAG = $00004000; // Machine Check Architecture
CMOV_FLAG = $00008000; // Conditional Move Instruction
PAT_FLAG = $00010000; // Page Attribute Table
PSE36_FLAG = $00020000; // 36-bit Page Size Extention
BIT_18 = $00040000; // Reserved, do not count on value
BIT_19 = $00080000; // Reserved, do not count on value
BIT_20 = $00100000; // Reserved, do not count on value
BIT_21 = $00200000; // Reserved, do not count on value
BIT_22 = $00400000; // Reserved, do not count on value
MMX_FLAG = $00800000; // MMX technology
FXSR_FLAG = $01000000; // Fast Floating Point Save and Restore
BIT_25 = $02000000; // Reserved, do not count on value
BIT_26 = $04000000; // Reserved, do not count on value
BIT_27 = $08000000; // Reserved, do not count on value
BIT_28 = $10000000; // Reserved, do not count on value
BIT_29 = $20000000; // Reserved, do not count on value
BIT_30 = $40000000; // Reserved, do not count on value
BIT_31 = DWORD($80000000); // Reserved, do not count on value
{ AMD Standard Feature Flags }
AMD_FPU_FLAG = $00000001; // Floating-Point unit on chip
AMD_VME_FLAG = $00000002; // Virtual Mode Extention
AMD_DE_FLAG = $00000004; // Debugging Extention
AMD_PSE_FLAG = $00000008; // Page Size Extention
AMD_TSC_FLAG = $00000010; // Time Stamp Counter
AMD_MSR_FLAG = $00000020; // Model Specific Registers
AMD_BIT_6 = $00000040; // Reserved, do not count on value
AMD_MCE_FLAG = $00000080; // Machine Check Exception
AMD_CX8_FLAG = $00000100; // CMPXCHG8 Instruction
AMD_APIC_FLAG = $00000200; // Software-accessible local APIC on Chip
AMD_BIT_10 = $00000400; // Reserved, do not count on value
AMD_BIT_11 = $00000800; // Reserved, do not count on value
AMD_MTRR_FLAG = $00001000; // Memory Type Range Registers
AMD_PGE_FLAG = $00002000; // Page Global Enable
AMD_BIT_14 = $00004000; // Reserved, do not count on value
AMD_CMOV_FLAG = $00008000; // Conditional Move Instruction
AMD_BIT_16 = $00010000; // Reserved, do not count on value
AMD_BIT_17 = $00020000; // Reserved, do not count on value
AMD_BIT_18 = $00040000; // Reserved, do not count on value
AMD_BIT_19 = $00080000; // Reserved, do not count on value
AMD_BIT_20 = $00100000; // Reserved, do not count on value
AMD_BIT_21 = $00200000; // Reserved, do not count on value
AMD_BIT_22 = $00400000; // Reserved, do not count on value
AMD_MMX_FLAG = $00800000; // MMX technology
AMD_BIT_24 = $01000000; // Reserved, do not count on value
AMD_BIT_25 = $02000000; // Reserved, do not count on value
AMD_BIT_26 = $04000000; // Reserved, do not count on value
AMD_BIT_27 = $08000000; // Reserved, do not count on value
AMD_BIT_28 = $10000000; // Reserved, do not count on value
AMD_BIT_29 = $20000000; // Reserved, do not count on value
AMD_BIT_30 = $40000000; // Reserved, do not count on value
AMD_BIT_31 = DWORD($80000000); // Reserved, do not count on value
{ AMD Enhanced Feature Flags }
EAMD_FPU_FLAG = $00000001; // Floating-Point unit on chip
EAMD_VME_FLAG = $00000002; // Virtual Mode Extention
EAMD_DE_FLAG = $00000004; // Debugging Extention
EAMD_PSE_FLAG = $00000008; // Page Size Extention
EAMD_TSC_FLAG = $00000010; // Time Stamp Counter
EAMD_MSR_FLAG = $00000020; // Model Specific Registers
EAMD_BIT_6 = $00000040; // Reserved, do not count on value
EAMD_MCE_FLAG = $00000080; // Machine Check Exception
EAMD_CX8_FLAG = $00000100; // CMPXCHG8 Instruction
EAMD_BIT_9 = $00000200; // Reserved, do not count on value
EAMD_BIT_10 = $00000400; // Reserved, do not count on value
EAMD_SEP_FLAG = $00000800; // Fast System Call
EAMD_BIT_12 = $00001000; // Reserved, do not count on value
EAMD_PGE_FLAG = $00002000; // Page Global Enable
EAMD_BIT_14 = $00004000; // Reserved, do not count on value
EAMD_ICMOV_FLAG = $00008000; // Integer Conditional Move Instruction
EAMD_FCMOV_FLAG = $00010000; // Floating Point Conditional Move Instruction
EAMD_BIT_17 = $00020000; // Reserved, do not count on value
EAMD_BIT_18 = $00040000; // Reserved, do not count on value
EAMD_BIT_19 = $00080000; // Reserved, do not count on value
EAMD_BIT_20 = $00100000; // Reserved, do not count on value
EAMD_BIT_21 = $00200000; // Reserved, do not count on value
EAMD_BIT_22 = $00400000; // Reserved, do not count on value
EAMD_MMX_FLAG = $00800000; // MMX technology
EAMD_BIT_24 = $01000000; // Reserved, do not count on value
EAMD_BIT_25 = $02000000; // Reserved, do not count on value
EAMD_BIT_26 = $04000000; // Reserved, do not count on value
EAMD_BIT_27 = $08000000; // Reserved, do not count on value
EAMD_BIT_28 = $10000000; // Reserved, do not count on value
EAMD_BIT_29 = $20000000; // Reserved, do not count on value
EAMD_BIT_30 = $40000000; // Reserved, do not count on value
EAMD_3DNOW_FLAG = DWORD($80000000); // AMD 3DNOW! Technology
{ Cyrix Standard Feature Flags }
CYRIX_FPU_FLAG = $00000001; // Floating-Point unit on chip
CYRIX_VME_FLAG = $00000002; // Virtual Mode Extention
CYRIX_DE_FLAG = $00000004; // Debugging Extention
CYRIX_PSE_FLAG = $00000008; // Page Size Extention
CYRIX_TSC_FLAG = $00000010; // Time Stamp Counter
CYRIX_MSR_FLAG = $00000020; // Model Specific Registers
CYRIX_PAE_FLAG = $00000040; // Physical Address Extention
CYRIX_MCE_FLAG = $00000080; // Machine Check Exception
CYRIX_CX8_FLAG = $00000100; // CMPXCHG8 Instruction
CYRIX_APIC_FLAG = $00000200; // Software-accessible local APIC on Chip
CYRIX_BIT_10 = $00000400; // Reserved, do not count on value
CYRIX_BIT_11 = $00000800; // Reserved, do not count on value
CYRIX_MTRR_FLAG = $00001000; // Memory Type Range Registers
CYRIX_PGE_FLAG = $00002000; // Page Global Enable
CYRIX_MCA_FLAG = $00004000; // Machine Check Architecture
CYRIX_CMOV_FLAG = $00008000; // Conditional Move Instruction
CYRIX_BIT_16 = $00010000; // Reserved, do not count on value
CYRIX_BIT_17 = $00020000; // Reserved, do not count on value
CYRIX_BIT_18 = $00040000; // Reserved, do not count on value
CYRIX_BIT_19 = $00080000; // Reserved, do not count on value
CYRIX_BIT_20 = $00100000; // Reserved, do not count on value
CYRIX_BIT_21 = $00200000; // Reserved, do not count on value
CYRIX_BIT_22 = $00400000; // Reserved, do not count on value
CYRIX_MMX_FLAG = $00800000; // MMX technology
CYRIX_BIT_24 = $01000000; // Reserved, do not count on value
CYRIX_BIT_25 = $02000000; // Reserved, do not count on value
CYRIX_BIT_26 = $04000000; // Reserved, do not count on value
CYRIX_BIT_27 = $08000000; // Reserved, do not count on value
CYRIX_BIT_28 = $10000000; // Reserved, do not count on value
CYRIX_BIT_29 = $20000000; // Reserved, do not count on value
CYRIX_BIT_30 = $40000000; // Reserved, do not count on value
CYRIX_BIT_31 = DWORD($80000000); // Reserved, do not count on value
{ Cyrix Enhanced Feature Flags }
ECYRIX_FPU_FLAG = $00000001; // Floating-Point unit on chip
ECYRIX_VME_FLAG = $00000002; // Virtual Mode Extention
ECYRIX_DE_FLAG = $00000004; // Debugging Extention
ECYRIX_PSE_FLAG = $00000008; // Page Size Extention
ECYRIX_TSC_FLAG = $00000010; // Time Stamp Counter
ECYRIX_MSR_FLAG = $00000020; // Model Specific Registers
ECYRIX_PAE_FLAG = $00000040; // Physical Address Extention
ECYRIX_MCE_FLAG = $00000080; // Machine Check Exception
ECYRIX_CX8_FLAG = $00000100; // CMPXCHG8 Instruction
ECYRIX_APIC_FLAG = $00000200; // Software-accessible local APIC on Chip
ECYRIX_SEP_FLAG = $00000400; // Fast System Call
ECYRIX_BIT_11 = $00000800; // Reserved, do not count on value
ECYRIX_MTRR_FLAG = $00001000; // Memory Type Range Registers
ECYRIX_PGE_FLAG = $00002000; // Page Global Enable
ECYRIX_MCA_FLAG = $00004000; // Machine Check Architecture
ECYRIX_ICMOV_FLAG = $00008000; // Integer Conditional Move Instruction
ECYRIX_FCMOV_FLAG = $00010000; // Floating Point Conditional Move Instruction
ECYRIX_BIT_17 = $00020000; // Reserved, do not count on value
ECYRIX_BIT_18 = $00040000; // Reserved, do not count on value
ECYRIX_BIT_19 = $00080000; // Reserved, do not count on value
ECYRIX_BIT_20 = $00100000; // Reserved, do not count on value
ECYRIX_BIT_21 = $00200000; // Reserved, do not count on value
ECYRIX_BIT_22 = $00400000; // Reserved, do not count on value
ECYRIX_MMX_FLAG = $00800000; // MMX technology
ECYRIX_EMMX_FLAG = $01000000; // Extended MMX Technology
ECYRIX_BIT_25 = $02000000; // Reserved, do not count on value
ECYRIX_BIT_26 = $04000000; // Reserved, do not count on value
ECYRIX_BIT_27 = $08000000; // Reserved, do not count on value
ECYRIX_BIT_28 = $10000000; // Reserved, do not count on value
ECYRIX_BIT_29 = $20000000; // Reserved, do not count on value
ECYRIX_BIT_30 = $40000000; // Reserved, do not count on value
ECYRIX_BIT_31 = DWORD($80000000); // Reserved, do not count on value
const
IntelCacheDescription: array [0..13] of TCacheInfo = (
(D: $01; I: RsIntelCacheDescr01),
(D: $02; I: RsIntelCacheDescr02),
(D: $03; I: RsIntelCacheDescr03),
(D: $04; I: RsIntelCacheDescr04),
(D: $06; I: RsIntelCacheDescr06),
(D: $08; I: RsIntelCacheDescr08),
(D: $0A; I: RsIntelCacheDescr0A),
(D: $0C; I: RsIntelCacheDescr0C),
(D: $40; I: RsIntelCacheDescr40),
(D: $41; I: RsIntelCacheDescr41),
(D: $42; I: RsIntelCacheDescr42),
(D: $43; I: RsIntelCacheDescr43),
(D: $44; I: RsIntelCacheDescr44),
(D: $45; I: RsIntelCacheDescr45));
procedure GetCpuInfo(var CpuInfo: TCpuInfo);
function GetIntelCacheDescription(const D: Byte): string;
function RoundFrequency(const Frequency: Integer): Integer;
function GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;
function CPUID: TCpuInfo;
function TestFDIVInstruction: Boolean;
//------------------------------------------------------------------------------
// Memory Information
//------------------------------------------------------------------------------
function GetMaxAppAddress: Integer;
function GetMinAppAddress: Integer;
function GetMemoryLoad: Byte;
function GetSwapFileSize: Integer;
function GetSwapFileUsage: Integer;
function GetTotalPhysicalMemory: Integer;
function GetFreePhysicalMemory: Integer;
function GetTotalPageFileMemory: Integer;
function GetFreePageFileMemory: Integer;
function GetTotalVirtualMemory: Integer;
function GetFreeVirtualMemory: Integer;
//------------------------------------------------------------------------------
// Alloc granularity
//------------------------------------------------------------------------------
procedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);
procedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);
//------------------------------------------------------------------------------
// Keyboard Information
//------------------------------------------------------------------------------
function GetKeyState(const VirtualKey: Cardinal): boolean;
function GetNumLockKeyState: boolean;
function GetScrollLockKeyState: boolean;
function GetCapsLockKeyState: boolean;
//------------------------------------------------------------------------------
// Public global variables
//------------------------------------------------------------------------------
var
ProcessorCount: Cardinal = 0;
AllocGranularity: Cardinal = 0;
PageSize: Cardinal = 0;
implementation
uses
Messages, SysUtils, TLHelp32, Winsock,
{$IFNDEF DELPHI5_UP}
JclSysUtils,
{$ENDIF DELPHI5_UP}
JclBase, JclFileUtils, JclRegistry, JclShell, JclStrings, JclWin32;
//==============================================================================
// Environment
//==============================================================================
function DelEnvironmentVar(const Name: string): Boolean;
begin
Result := SetEnvironmentVariable(PChar(Name), nil);
end;
//------------------------------------------------------------------------------
function ExpandEnvironmentVar(var Value: string): Boolean;
var
R: Integer;
Expanded: string;
begin
R := ExpandEnvironmentStrings(PChar(Value), nil, 0);
SetLength(Expanded, R);
Result := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), R) <> 0;
if Result then
begin
StrResetLength(Expanded);
Value := Expanded;
end;
end;
//------------------------------------------------------------------------------
function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
var
R: DWORD;
begin
R := GetEnvironmentVariable(PChar(Name), nil, 0);
SetLength(Value, R);
R := GetEnvironmentVariable(PChar(Name), PChar(Value), R);
Result := R <> 0;
if not Result then
Value := ''
else
begin
SetLength(Value, R);
if Expand then
ExpandEnvironmentVar(Value);
end;
end;
//------------------------------------------------------------------------------
function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
var
Raw: PChar;
Expanded: string;
I: Integer;
begin
Vars.Clear;
Raw := GetEnvironmentStrings;
try
MultiSzToStrings(Vars, Raw);
Result := True;
finally
FreeEnvironmentStrings(Raw);
end;
if Expand then
begin
for I := 0 to Vars.Count - 1 do
begin
Expanded := Vars[I];
if ExpandEnvironmentVar(Expanded) then
Vars[I] := Expanded;
end;
end;
end;
//------------------------------------------------------------------------------
function SetEnvironmentVar(const Name, Value: string): Boolean;
begin
Result := SetEnvironmentVariable(PChar(Name), PChar(Value));
end;
//------------------------------------------------------------------------------
function CreateEnvironmentBlock(const Options: TEnvironmentOptions; const AdditionalVars: TStrings): PChar;
const
RegLocalEnvironment = 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment';
RegUserEnvironment = '\Environment\';
var
KeyNames, TempList: TStrings;
Temp, Name, Value: string;
I: Integer;
begin
TempList := TStringList.Create;
try
// add additional environment variables
if eoAdditional in Options then
for I := 0 to AdditionalVars.Count - 1 do
begin
Temp := AdditionalVars[I];
ExpandEnvironmentVar(Temp);
TempList.Add(Temp);
end;
// get environment strings from local machine
if eoLocalMachine in Options then
begin
KeyNames := TStringList.Create;
try
if RegGetValueNames(HKEY_LOCAL_MACHINE, RegLocalEnvironment, KeyNames) then
begin
for I := 0 to KeyNames.Count - 1 do
begin
Name := KeyNames[I];
Value := RegReadString(HKEY_LOCAL_MACHINE, RegLocalEnvironment, Name);
ExpandEnvironmentVar(Value);
TempList.Add(Name + '=' + Value);
end;
end;
finally
FreeAndNil(KeyNames);
end;
end;
// get environment strings from current user
if eoCurrentUser in Options then
begin
KeyNames := TStringLIst.Create;
try
if RegGetValueNames(HKEY_CURRENT_USER, RegUserEnvironment, KeyNames) then
begin
for I := 0 to KeyNames.Count - 1 do
begin
Name := KeyNames[I];
Value := RegReadString(HKEY_CURRENT_USER, RegUserEnvironment, Name);
ExpandEnvironmentVar(Value);
TempList.Add(Name + '=' + Value);
end;
end;
finally
KeyNames.Free;
end;
end;
// transform stringlist into multi-PChar
StringsToMultiSz(Result, TempList);
finally
FreeAndNil(TempList);
end;
end;
//==============================================================================
// Common Folders
//==============================================================================
const
HKLM_CURRENT_VERSION_WINDOWS = 'Software\Microsoft\Windows\CurrentVersion';
HKLM_CURRENT_VERSION_NT = 'Software\Microsoft\Windows NT\CurrentVersion';
// Utility function which returns the Windows independent CurrentVersion key
// inside HKEY_LOCAL_MACHINE
function REG_CURRENT_VERSION: string;
begin
if IsWinNT then
Result := HKLM_CURRENT_VERSION_NT
else
Result := HKLM_CURRENT_VERSION_WINDOWS;
end;
//------------------------------------------------------------------------------
function GetCommonFilesFolder: string;
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS,
'CommonFilesDir', '');
end;
//------------------------------------------------------------------------------
function GetCurrentFolder: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetCurrentDirectory(0, nil);
if Required <> 0 then
begin
SetLength(Result, Required);
GetCurrentDirectory(Required, PChar(Result));
StrResetLength(Result);
end;
end;
//------------------------------------------------------------------------------
function GetProgramFilesFolder: string;
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS,
'ProgramFilesDir', '');
end;
//------------------------------------------------------------------------------
function GetWindowsFolder: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetWindowsDirectory(nil, 0);
if Required <> 0 then
begin
SetLength(Result, Required);
GetWindowsDirectory(PChar(Result), Required);
StrResetLength(Result);
end;
end;
//------------------------------------------------------------------------------
function GetWindowsSystemFolder: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetSystemDirectory(nil, 0);
if Required <> 0 then
begin
SetLength(Result, Required);
GetSystemDirectory(PChar(Result), Required);
StrResetLength(Result);
end;
end;
//------------------------------------------------------------------------------
function GetWindowsTempFolder: string;
var
Required: Cardinal;
begin
Result := '';
Required := GetTempPath(0, nil);
if Required <> 0 then
begin
SetLength(Result, Required);
GetTempPath(Required, PChar(Result));
StrResetLength(Result);
Result := PathRemoveSeparator(Result);
end;
end;
//------------------------------------------------------------------------------
function GetDesktopFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_DESKTOP);
end;
//------------------------------------------------------------------------------
function GetProgramsFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_PROGRAMS);
end;
//------------------------------------------------------------------------------
function GetPersonalFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_PERSONAL);
end;
//------------------------------------------------------------------------------
function GetFavoritesFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_FAVORITES);
end;
//------------------------------------------------------------------------------
function GetStartupFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_STARTUP);
end;
//------------------------------------------------------------------------------
function GetRecentFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_RECENT);
end;
//------------------------------------------------------------------------------
function GetSendToFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_SENDTO);
end;
//------------------------------------------------------------------------------
function GetStartmenuFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_STARTMENU);
end;
//------------------------------------------------------------------------------
function GetDesktopDirectoryFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_DESKTOPDIRECTORY);
end;
//------------------------------------------------------------------------------
function GetNethoodFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_NETHOOD);
end;
//------------------------------------------------------------------------------
function GetFontsFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_FONTS);
end;
//------------------------------------------------------------------------------
function GetCommonStartmenuFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTMENU);
end;
//------------------------------------------------------------------------------
function GetCommonProgramsFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_PROGRAMS);
end;
//------------------------------------------------------------------------------
function GetCommonStartupFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTUP);
end;
//------------------------------------------------------------------------------
function GetCommonDesktopdirectoryFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_DESKTOPDIRECTORY);
end;
//------------------------------------------------------------------------------
function GetAppdataFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_APPDATA);
end;
//------------------------------------------------------------------------------
function GetPrinthoodFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_PRINTHOOD);
end;
//------------------------------------------------------------------------------
function GetCommonFavoritesFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COMMON_FAVORITES);
end;
//------------------------------------------------------------------------------
function GetTemplatesFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_TEMPLATES);
end;
//------------------------------------------------------------------------------
function GetInternetCacheFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_INTERNET_CACHE);
end;
//------------------------------------------------------------------------------
function GetCookiesFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_COOKIES);
end;
//------------------------------------------------------------------------------
function GetHistoryFolder: string;
begin
Result := GetSpecialFolderLocation(CSIDL_HISTORY);
end;
// the following special folders are pure virtual and cannot be
// mapped to a directory path:
// CSIDL_INTERNET
// CSIDL_CONTROLS
// CSIDL_PRINTERS
// CSIDL_BITBUCKET
// CSIDL_DRIVES
// CSIDL_NETWORK
// CSIDL_ALTSTARTUP
// CSIDL_COMMON_ALTSTARTUP
//==============================================================================
// Identification
//==============================================================================
type
TVolumeInfoKind = (vikName, vikSerial, vikFileSystem);
function GetVolumeInfoHelper(const Drive: string; InfoKind: TVolumeInfoKind): string;
var
VolumeSerialNumber: DWORD;
MaximumComponentLength: DWORD;
Flags: DWORD;
Name: array [0..MAX_PATH] of Char;
FileSystem: array [0..15] of Char;
ErrorMode: Cardinal;
DriveStr: string;
begin
// TODO Perform better checking of Drive param or document that no checking is
// performed. RM Suggested:
// DriveStr := Drive;
// if (Length(Drive) < 2) or (Drive[2] <> ':') then
// DriveStr := GetCurrentFolder;
// DriveStr := DriveStr[1] + ':\';
Result := '';
DriveStr := Drive + ':\';
ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if GetVolumeInformation(PChar(DriveStr), Name, SizeOf(Name), @VolumeSerialNumber,
MaximumComponentLength, Flags, FileSystem, SizeOf(FileSystem)) then
case InfoKind of
vikName:
Result := StrPas(Name);
vikSerial:
begin
Result := IntToHex(HiWord(VolumeSerialNumber), 4) + '-' +
IntToHex(LoWord(VolumeSerialNumber), 4);
end;
vikFileSystem:
Result := StrPas(FileSystem);
end;
finally
SetErrorMode(ErrorMode);
end;
end;
//------------------------------------------------------------------------------
function GetVolumeName(const Drive: string): string;
begin
Result := GetVolumeInfoHelper(Drive, vikName);
end;
//------------------------------------------------------------------------------
function GetVolumeSerialNumber(const Drive: string): string;
begin
Result := GetVolumeInfoHelper(Drive, vikSerial);
end;
//------------------------------------------------------------------------------
function GetVolumeFileSystem(const Drive: string): string;
begin
Result := GetVolumeInfoHelper(Drive, vikFileSystem);
end;
//------------------------------------------------------------------------------
function GetIPAddress(const HostName: string): string;
var
R: Integer;
WSAData: TWSAData;
HostEnt: PHostEnt;
Host: string;
SockAddr: TSockAddrIn;
begin
Result := '';
R := WSAStartup(MakeWord(1, 1), WSAData);
if R = 0 then
try
Host := HostName;
if Host = '' then
begin
SetLength(Host, MAX_PATH);
GetHostName(PChar(Host), MAX_PATH);
end;
HostEnt := GetHostByName(PChar(Host));
if HostEnt <> nil then
begin
SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
Result := inet_ntoa(SockAddr.sin_addr);
end;
finally
WSACleanup;
end;
end;
//------------------------------------------------------------------------------
function GetLocalComputerName: string;
var
Count: DWORD;
begin
Count := MAX_COMPUTERNAME_LENGTH + 1;
// set buffer size to MAX_COMPUTERNAME_LENGTH + 2 characters for safety
SetLength(Result, Count);
Win32Check(GetComputerName(PChar(Result), Count));
StrResetLength(Result);
end;
//------------------------------------------------------------------------------
function GetLocalUserName: string;
var
Count: DWORD;
begin
Count := 256 + 1; // UNLEN + 1
// set buffer size to 256 + 2 characters
SetLength(Result, Count);
Win32Check(GetUserName(PChar(Result), Count));
StrResetLength(Result);
end;
//------------------------------------------------------------------------------
function GetRegisteredCompany: string;
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION,
'RegisteredOrganization', '');
end;
//------------------------------------------------------------------------------
function GetRegisteredOwner: string;
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION,
'RegisteredOwner', '');
end;
//------------------------------------------------------------------------------
function GetUserDomainName(const CurUser: string): string;
var
Count1, Count2: DWORD;
Sd: PSecurityDescriptor;
Snu: SID_Name_Use;
begin
Count1 := 0;
Count2 := 0;
Sd := nil;
Snu := SIDTypeUser;
LookUpAccountName(nil, PChar(CurUser), Sd, Count1, PChar(Result), Count2, Snu);
// set buffer size to Count2 + 2 characters for safety
SetLength(Result, Count2 + 1);
Sd := AllocMem(Count1);
try
if LookUpAccountName(nil, PChar(CurUser), Sd, Count1, PChar(Result), Count2, Snu) then
StrResetLength(Result)
else
Result := EmptyStr;
finally
FreeMem(Sd);
end;
end;
//------------------------------------------------------------------------------
function GetDomainName: string;
begin
Result := GetUserDomainName(GetLocalUserName);
end;
//------------------------------------------------------------------------------
function GetBIOSName: string;
const
ADR_BIOSNAME = $FE061;
begin
try
Result := string(PChar(Ptr(ADR_BIOSNAME)));
except
Result := '';
end;
end;
//------------------------------------------------------------------------------
function GetBIOSCopyright: string;
const
ADR_BIOSCOPYRIGHT = $FE091;
begin
try
Result := string(PChar(Ptr(ADR_BIOSCOPYRIGHT)));
except
Result := '';
end;
end;
//------------------------------------------------------------------------------
function GetBIOSExtendedInfo: string;
const
ADR_BIOSEXTENDEDINFO = $FEC71;
begin
try
Result := string(PChar(Ptr(ADR_BIOSEXTENDEDINFO)));
except
Result := '';
end;
end;
//------------------------------------------------------------------------------
function GetBIOSDate : TDateTime;
const
REGSTR_PATH_SYSTEM = '\HARDWARE\DESCRIPTION\System';
REGSTR_SYSTEMBIOSDATE = 'SystemBiosDate';
var
RegStr, RegFormat: string;
RegSeparator: Char;
begin
Result := 0;
RegStr := RegReadString(HKEY_LOCAL_MACHINE, REGSTR_PATH_SYSTEM, REGSTR_SYSTEMBIOSDATE);
RegFormat := ShortDateFormat;
RegSeparator := DateSeparator;
try
DateSeparator := '/';
try
ShortDateFormat := 'm/d/y';
Result := StrToDate(RegStr);
except
try
ShortDateFormat := 'y/m/d';
Result := StrToDate(RegStr);
except
end;
end;
finally
ShortDateFormat := RegFormat;
DateSeparator := RegSeparator;
end;
end;
//==============================================================================
// Processes, Tasks and Modules
//==============================================================================
function RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;
function ProcessFileName(PID: DWORD): string;
var
Handle: THandle;
begin
Result := '';
Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);
if Handle <> 0 then
try
SetLength(Result, MAX_PATH);
if FullPath then
begin
if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
StrResetLength(Result)
else
Result := '';
end
else
begin
if GetModuleBaseNameA(Handle, 0, PChar(Result), MAX_PATH) > 0 then
StrResetLength(Result)
else
Result := '';
end;
finally
CloseHandle(Handle);
end;
end;
function BuildListTH: Boolean;
var
SnapProcHandle: THandle;
ProcEntry: TProcessEntry32;
NextProc: Boolean;
FileName: string;
begin
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);
if Result then
try
ProcEntry.dwSize := SizeOf(ProcEntry);
NextProc := Process32First(SnapProcHandle, ProcEntry);
while NextProc do
begin
if ProcEntry.th32ProcessID = 0 then
begin
// PID 0 is always the "System Idle Process" but this name cannot be
// retrieved from the system and has to be fabricated.
FileName := RsSystemIdleProcess;
end
else
begin
if IsWin2k then
begin
FileName := ProcessFileName(ProcEntry.th32ProcessID);
if FileName = '' then
FileName := ProcEntry.szExeFile;
end
else
begin
FileName := ProcEntry.szExeFile;
if not FullPath then
FileName := ExtractFileName(FileName);
end;
end;
List.AddObject(FileName, Pointer(ProcEntry.th32ProcessID));
NextProc := Process32Next(SnapProcHandle, ProcEntry);
end;
finally
CloseHandle(SnapProcHandle);
end;
end;
function BuildListPS: Boolean;
var
PIDs: array [0..1024] of DWORD;
Needed: DWORD;
I: Integer;
FileName: string;
begin
Result := EnumProcesses(@PIDs, SizeOf(PIDs), Needed);
if Result then
begin
for I := 0 to (Needed div SizeOf(DWORD)) - 1 do
begin
case PIDs[I] of
0:
// PID 0 is always the "System Idle Process" but this name cannot be
// retrieved from the system and has to be fabricated.
FileName := RsSystemIdleProcess;
2:
// On NT 4 PID 2 is the "System Process" but this name cannot be
// retrieved from the system and has to be fabricated.
if IsWinNT4 then
FileName := RsSystemProcess
else
FileName := ProcessFileName(PIDs[I]);
8:
// On Win2K PID 8 is the "System Process" but this name cannot be
// retrieved from the system and has to be fabricated.
if IsWin2K then
FileName := RsSystemProcess
else
FileName := ProcessFileName(PIDs[I]);
else
FileName := ProcessFileName(PIDs[I]);
end;
if FileName <> '' then
List.AddObject(FileName, Pointer(PIDs[I]));
end;
end;
end;
begin
if GetWindowsVersion in [wvWinNT3, wvWinNT4] then
Result := BuildListPS
else
Result := BuildListTH;
end;
//------------------------------------------------------------------------------
function LoadedModulesList(const List: TStrings; ProcessID: DWORD): Boolean;
procedure AddToList(ProcessHandle: THandle; Module: HMODULE);
var
FileName: array [0..MAX_PATH] of Char;
ModuleInfo: TModuleInfo;
begin
if (GetModuleFileNameEx(ProcessHandle, Module, Filename, SizeOf(Filename)) > 0) and
(GetModuleInformation(ProcessHandle, Module, @ModuleInfo, SizeOf(ModuleInfo))) then
List.AddObject(FileName, Pointer(ModuleInfo.lpBaseOfDll));
end;
function EnumModulesVQ(ProcessHandle: THandle): Boolean;
var
MemInfo: TMemoryBasicInformation;
Base: PChar;
LastAllocBase: Pointer;
Res: DWORD;
begin
Base := nil;
LastAllocBase := nil;
FillChar(MemInfo, SizeOf(MemInfo), #0);
Res := VirtualQueryEx(ProcessHandle, Base, MemInfo, SizeOf(MemInfo));
Result := (Res = SizeOf(MemInfo));
while Res = SizeOf(MemInfo) do
begin
if MemInfo.AllocationBase <> LastAllocBase then
begin
if MemInfo.Type_9 = MEM_IMAGE then
AddToList(ProcessHandle, HMODULE(MemInfo.AllocationBase));
LastAllocBase := MemInfo.AllocationBase;
end;
Inc(Base, MemInfo.RegionSize);
Res := VirtualQueryEx(ProcessHandle, Base, MemInfo, SizeOf(MemInfo));
end;
end;
function EnumModulesPS: Boolean;
var
ProcessHandle: THandle;
Needed: DWORD;
Modules: array of THandle;
I, Cnt: Integer;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle <> 0 then
try
Result := EnumProcessModules(ProcessHandle, nil, 0, Needed);
if Result then
begin
Cnt := Needed div SizeOf(HMODULE);
SetLength(Modules, Cnt);
if EnumProcessModules(ProcessHandle, @Modules[0], Needed, Needed) then
for I := 0 to Cnt - 1 do
AddToList(ProcessHandle, Modules[I]);
end
else
Result := EnumModulesVQ(ProcessHandle);
finally
CloseHandle(ProcessHandle);
end;
end;
function EnumModulesTH: Boolean;
var
SnapProcHandle: THandle;
Module: TModuleEntry32;
Next: Boolean;
begin
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);
if Result then
try
FillChar(Module, SizeOf(Module), #0);
Module.dwSize := SizeOf(Module);
Next := Module32First(SnapProcHandle, Module);
while Next do
begin
List.AddObject(Module.szExePath, Pointer(Module.hModule));
Next := Module32Next(SnapProcHandle, Module);
end;
finally
CloseHandle(SnapProcHandle);
end;
end;
begin
if IsWinNT then
Result := EnumModulesPS
else
Result := EnumModulesTH;
end;
//------------------------------------------------------------------------------
// http://msdn.microsoft.com/library/periodic/period97/win321197.htm
function GetTasksList(const List: TStrings): Boolean;
function EnumWindowsProc(Wnd: HWND; List: TStrings): Boolean; stdcall;
var
ParentWnd: HWND;
ExStyle: DWORD;
Caption: array [0..255] of Char;
begin
if IsWindowVisible(Wnd) then
begin
ParentWnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
ExStyle := GetWindowLong(Wnd, GWL_EXSTYLE);
if ((ParentWnd = 0) or (ParentWnd = GetDesktopWindow)) and
((ExStyle and WS_EX_TOOLWINDOW = 0) or (ExStyle and WS_EX_APPWINDOW <> 0)) and
(GetWindowText(Wnd, Caption, SizeOf(Caption)) > 0) then
List.AddObject(Caption, Pointer(Wnd));
end;
Result := True;
end;
begin
Result := EnumWindows(@EnumWindowsProc, Integer(List));
end;
//------------------------------------------------------------------------------
function IsWindowResponding(Wnd: HWND; Timeout: Integer): Boolean;
var
Res: DWORD;
begin
Result := SendMessageTimeout(Wnd, WM_NULL, 0, 0, SMTO_ABORTIFHUNG, Timeout, Res) <> 0;
end;
//------------------------------------------------------------------------------
function GetWindowIcon(Wnd: HWND; LargeIcon: Boolean): HICON;
var
Width, Height: Integer;
TempIcon: HICON;
IconType: DWORD;
begin
if LargeIcon then
begin
Width := GetSystemMetrics(SM_CXICON);
Height := GetSystemMetrics(SM_CYICON);
IconType := ICON_BIG;
TempIcon := GetClassLong(Wnd, GCL_HICON);
end
else
begin
Width := GetSystemMetrics(SM_CXSMICON);
Height := GetSystemMetrics(SM_CYSMICON);
IconType := ICON_SMALL;
TempIcon := GetClassLong(Wnd, GCL_HICONSM);
end;
if TempIcon = 0 then
TempIcon := SendMessage(Wnd, WM_GETICON, IconType, 0);
if (TempIcon = 0) and not LargeIcon then
TempIcon := SendMessage(Wnd, WM_GETICON, ICON_BIG, 0);
Result := CopyImage(TempIcon, IMAGE_ICON, Width, Height, 0);
end;
//------------------------------------------------------------------------------
// Q178893
function TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;
var
ProcessHandle: THandle;
function EnumWindowsProc(Wnd: HWND; ProcessID: DWORD): Boolean; stdcall;
var
PID: DWORD;
begin
GetWindowThreadProcessId(Wnd, @PID);
if ProcessID = PID then
PostMessage(Wnd, WM_CLOSE, 0, 0);
Result := True;
end;
begin
Result := taError;
if ProcessID <> GetCurrentProcessId then
begin
ProcessHandle := OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False, ProcessID);
try
if ProcessHandle <> 0 then
begin
EnumWindows(@EnumWindowsProc, LPARAM(ProcessID));
if WaitForSingleObject(ProcessHandle, Timeout) = WAIT_OBJECT_0 then
Result := taClean
else
if TerminateProcess(ProcessHandle, 0) then
Result := taKill;
end;
finally
CloseHandle(ProcessHandle);
end;
end;
end;
//------------------------------------------------------------------------------
function TerminateTask(Wnd: HWND; Timeout: Integer): TJclTerminateAppResult;
var
PID: DWORD;
begin
if GetWindowThreadProcessId(Wnd, @PID) <> 0 then
Result := TerminateApp(PID, Timeout)
else
Result := taError;
end;
//------------------------------------------------------------------------------
function GetProcessNameFromWnd(Wnd: HWND): string;
var
List: TStringList;
PID: DWORD;
I: Integer;
begin
Result := '';
if IsWindow(Wnd) then
begin
PID := INVALID_HANDLE_VALUE;
GetWindowThreadProcessId(Wnd, @PID);
List := TStringList.Create;
try
if RunningProcessesList(List, True) then
begin
I := List.IndexOfObject(Pointer(PID));
if I > -1 then
Result := List[I];
end;
finally
List.Free;
end;
end;
end;
//------------------------------------------------------------------------------
function GetPidFromProcessName(const ProcessName: string): DWORD;
var
List: TStringList;
I: Integer;
begin
Result := INVALID_HANDLE_VALUE;
List := TStringList.Create;
try
if RunningProcessesList(List, True) then
begin
I := List.IndexOf(ProcessName);
if I > -1 then
Result := DWORD(List.Objects[I]);
end;
finally
List.Free;
end;
end;
//------------------------------------------------------------------------------
function GetProcessNameFromPid(PID: DWORD): string;
var
List: TStringList;
I: Integer;
begin
// Note: there are other ways to retrieve the name of the process given it's
// PID but this implementation seems to work best without making assumptions
// although it may not be the most efficient implementation.
Result := '';
List := TStringList.Create;
try
if RunningProcessesList(List, True) then
begin
I := List.IndexOfObject(Pointer(PID));
if I > -1 then
Result := List[I];
end;
finally
List.Free;
end;
end;
//------------------------------------------------------------------------------
resourcestring
RsProcessNotFound = 'Process %s not found.';
function GetProcessPid(const Name: string): Longword;
var
Snapshot: THandle;
Process: TProcessEntry32;
Success, NextEntryFound: Boolean;
begin
Result := 0;
Success := False;
Snapshot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Snapshot <> INVALID_HANDLE_VALUE then
try
FillChar(Process, SizeOf(Process), 0);
Process.dwSize := SizeOf(Process);
NextEntryFound := Process32First(Snapshot, Process);
while NextEntryFound do
begin
if CompareText(Process.szExeFile, Name) = 0 then
begin
Result := Process.th32ProcessID;
Success := True;
Break;
end;
NextEntryFound := Process32Next(Snapshot, Process);
end;
finally
CloseHandle(Snapshot);
end;
if not Success then
raise Exception.CreateResFmt(@RsProcessNotFound, [Name]);
end;
//------------------------------------------------------------------------------
function GetShellProcessName: string;
const
cShellKey = 'Software\Microsoft\Windows NT\CurrentVersion\WinLogon';
cShellValue = 'Shell';
cShellDefault = 'explorer.exe';
begin
Result := RegReadStringDef(HKEY_LOCAL_MACHINE, cShellKey, cShellValue, '');
if Result = '' then
Result := cShellDefault;
end;
//------------------------------------------------------------------------------
function GetShellProcessHandle: THandle;
var
Pid: Longword;
begin
Pid := GetProcessPid(GetShellProcessName);
Result := OpenProcess(PROCESS_ALL_ACCESS, False, Pid);
if Result = 0 then
RaiseLastOSError;
end;
//==============================================================================
// Version Information
//==============================================================================
{ Q159/238
Windows 95 retail, OEM 4.00.950 7/11/95
Windows 95 retail SP1 4.00.950A 7/11/95-12/31/95
OEM Service Release 2 4.00.1111* (4.00.950B) 8/24/96
OEM Service Release 2.1 4.03.1212-1214* (4.00.950B) 8/24/96-8/27/97
OEM Service Release 2.5 4.03.1214* (4.00.950C) 8/24/96-11/18/97
Windows 98 retail, OEM 4.10.1998 5/11/98
Windows 98 Second Edition 4.10.2222A 4/23/99
Windows Millennium 4.90.3000
TODO: Distinquish between all these different releases?
}
var
KernelVersionHi: DWORD;
function GetWindowsVersion: TWindowsVersion;
begin
Result := wvUnknown;
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
case Win32MinorVersion of
0..9:
if Trim(Win32CSDVersion) = 'B' then
Result := wvWin95OSR2
else
Result := wvWin95;
10..89:
// On Windows ME Win32MinorVersion can be 10 (indicating Windows 98
// under certain circumstances (image name is setup.exe). Checking
// the kernel version is one way of working around that.
if KernelVersionHi = $0004005A then // 4.90.x.x
Result := wvWinME
else
if Trim(Win32CSDVersion) = 'A' then
Result := wvWin98SE
else
Result := wvWin98;
90:
Result := wvWinME;
end;
VER_PLATFORM_WIN32_NT:
case Win32MajorVersion of
3:
Result := wvWinNT3;
4:
Result := wvWinNT4;
5:
case Win32MinorVersion of
0:
Result := wvWin2000;
1:
Result := wvWinXP;
end;
end;
end;
end;
//------------------------------------------------------------------------------
function NtProductType: TNtProductType;
const
ProductType = 'System\CurrentControlSet\Control\ProductOptions';
var
Product: string;
VersionInfo: TOSVersionInfoEx;
begin
Result := ptUnknown;
FillChar(VersionInfo, SizeOf(VersionInfo), 0);
VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
// Favor documented API over registry
if IsWinNT4 and (GetWindowsServicePackVersion >= 6) then
begin
if JclWin32.GetVersionEx(@VersionInfo) then
begin
if (VersionInfo.wProductType = VER_NT_WORKSTATION) then
Result := ptWorkstation
else
Result := ptServer;
end;
end
else if IsWin2K then
begin
if JclWin32.GetVersionEx(@VersionInfo) then
begin
if (VersionInfo.wProductType = VER_NT_SERVER) then
begin
if (VersionInfo.wSuiteMask = VER_SUITE_DATACENTER) then
Result := ptDatacenterServer
else if (VersionInfo.wSuiteMask = VER_SUITE_ENTERPRISE) then
Result := ptAdvancedServer
else
result := ptServer;
end
else if (VersionInfo.wProductType = VER_NT_WORKSTATION) then
Result := ptProfessional;
end;
end
else
if IsWinXP then
begin
if JclWin32.GetVersionEx(@VersionInfo) then
begin
if (VersionInfo.wProductType = VER_NT_WORKSTATION) then
begin
if VersionInfo.wSuiteMask = VER_SUITE_PERSONAL then
Result := ptPersonal
else
Result := ptProfessional;
end;
end;
end;
Result := ptUnknown;
if Result = ptUnknown then
begin
// Non Windows 2000/XP system or the above method failed, try registry
Product := RegReadStringDef(HKEY_LOCAL_MACHINE, ProductType, 'ProductType', '');
if CompareText(Product, 'WINNT') = 0 then
Result := ptWorkStation
else
if CompareText(Product, 'SERVERNT') = 0 then
Result := ptServer
else
if CompareText(Product, 'LANMANNT') = 0 then
Result := ptAdvancedServer
else
Result := ptUnknown;
end;
end;
//------------------------------------------------------------------------------
// todo mvb move to jclresources
resourcestring
RsOSVersionWin95 = 'Windows 95';
RsOSVersionWin95OSR2 = 'Windows 95 OSR2';
RsOSVersionWin98 = 'Windows 98';
RsOSVersionWin98SE = 'Windows 98 SE';
RsOSVersionWinME = 'Windows ME';
RsOSVersionWinNT3 = 'Windows NT 3.%u';
RsOSVersionWinNT4 = 'Windows NT 4.%u';
RsOSVersionWin2000 = 'Windows 2000';
RsOSVersionWinXP = 'Windows XP';
function GetWindowsVersionString: string;
begin
case GetWindowsVersion of
wvWin95: Result := RsOSVersionWin95;
wvWin95OSR2: Result := RsOSVersionWin95OSR2;
wvWin98: Result := RsOSVersionWin98;
wvWin98SE: Result := RsOSVersionWin98SE;
wvWinME: Result := RsOSVersionWinME;
wvWinNT3: Result := Format(RsOSVersionWinNT3, [Win32MinorVersion]);
wvWinNT4: Result := Format(RsOSVersionWinNT4, [Win32MinorVersion]);
wvWin2000: Result := RsOSVersionWin2000;
wvWinXP: Result := RsOSVersionWinXP;
else
Result := '';
end;
end;
//------------------------------------------------------------------------------
// todo mvb move
resourcestring
RsProductTypeWorkStation = 'Workstation';
RsProductTypeServer = 'Server';
RsProductTypeAdvancedServer = 'Advanced Server';
RsProductTypePersonal = 'Home Edition';
RsProductTypeProfessional = 'Professional';
RsProductTypeDatacenterServer = 'Datacenter Server';
function NtProductTypeString: string;
begin
case NtProductType of
ptWorkStation: Result := RsProductTypeWorkStation;
ptServer: Result := RsProductTypeServer;
ptAdvancedServer: Result := RsProductTypeAdvancedServer;
ptPersonal: Result := RsProductTypePersonal;
ptProfessional: Result := RsProductTypeProfessional;
ptDatacenterServer: Result := RsProductTypeDatacenterServer;
else
Result := '';
end;
end;
//------------------------------------------------------------------------------
function GetWindowsServicePackVersion: Integer;
var
VersionInfo: TOSVersionInfoEx;
begin
Result := 0;
if IsWin2K or IsWinXP then
begin
FillChar(VersionInfo, SizeOf(VersionInfo), 0);
VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
if JclWin32.GetVersionEx(@VersionInfo) then
Result := VersionInfo.wServicePackMajor;
end
else
Result := StrToInt(IntToHex(RegReadIntegerDef(HKEY_LOCAL_MACHINE,
'\SYSTEM\CurrentControlSet\Control\Windows\', 'CSDVersion', 0), 4)) div 100;
end;
//==============================================================================
// Hardware
//==============================================================================
// Helper function for GetMacAddress()
// Converts the adapter_address array to a string
function AdapterToString(Adapter: TAdapterStatus): string;
begin
with Adapter do
Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x', [
Integer(adapter_address[0]), Integer(adapter_address[1]),
Integer(adapter_address[2]), Integer(adapter_address[3]),
Integer(adapter_address[4]), Integer(adapter_address[5])]);
end;
//------------------------------------------------------------------------------
function GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;
var
NCB: TNCB;
Enum: TLanaEnum;
I, L, NameLen: Integer;
Adapter: ASTAT;
MachineName: string;
begin
Result := -1;
Addresses.Clear;
MachineName := UpperCase(Machine);
if MachineName = '' then
MachineName := '*';
NameLen := Length(MachineName);
L := NCBNAMSZ - NameLen;
if L > 0 then
begin
SetLength(MachineName, NCBNAMSZ);
FillChar(MachineName[NameLen + 1], L, ' ');
end;
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := NCBENUM;
NCB.ncb_buffer := Pointer(@Enum);
NCB.ncb_length := SizeOf(Enum);
if NetBios(@NCB) = NRC_GOODRET then
begin
Result := Enum.Length;
for I := 0 to Ord(Enum.Length) - 1 do
begin
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := NCBRESET;
NCB.ncb_lana_num := Enum.lana[I];
if NetBios(@NCB) = NRC_GOODRET then
begin
FillChar(NCB, SizeOf(NCB), #0);
NCB.ncb_command := NCBASTAT;
NCB.ncb_lana_num := Enum.lana[I];
Move(MachineName[1], NCB.ncb_callname, SizeOf(NCB.ncb_callname));
NCB.ncb_buffer := PChar(@Adapter);
NCB.ncb_length := SizeOf(Adapter);
if NetBios(@NCB) = NRC_GOODRET then
Addresses.Add(AdapterToString(Adapter.adapt));
end;
end;
end;
end;
//------------------------------------------------------------------------------
function ReadTimeStampCounter: Int64; assembler;
asm
{$IFNDEF SUPPORTS_INT64}
MOV ECX, EAX
DW $310F
MOV [ECX], EAX
MOV [ECX+$04], EDX
{$ELSE}
DW $310F
{$ENDIF SUPPORTS_INT64}
end;
//------------------------------------------------------------------------------
function GetIntelCacheDescription(const D: Byte): string;
var
I: Integer;
begin
Result := '';
if D <> 0 then
begin
for I := Low(IntelCacheDescription) to High(IntelCacheDescription) do
begin
if IntelCacheDescription[I].D = D then
begin
Result := IntelCacheDescription[I].I;
Break;
end;
end;
end;
end;
//------------------------------------------------------------------------------
procedure GetCpuInfo(var CpuInfo: TCpuInfo);
begin
CpuInfo := CPUID;
CpuInfo.IsFDIVOK := TestFDIVInstruction;
if CpuInfo.HasInstruction then
begin
if (CpuInfo.Features and TSC_FLAG) = TSC_FLAG then
GetCpuSpeed(CpuInfo.FrequencyInfo);
CpuInfo.MMX := (CpuInfo.Features and MMX_FLAG) = MMX_FLAG;
end;
end;
//------------------------------------------------------------------------------
function RoundFrequency(const Frequency: Integer): Integer;
const
NF: array [0..8] of Integer = (0, 20, 33, 50, 60, 66, 80, 90, 100);
var
Freq, RF: Integer;
I: Byte;
Hi, Lo: Byte;
begin
RF := 0;
Freq := Frequency mod 100;
for I := 0 to 8 do
begin
if Freq < NF[I] then
begin
Hi := I;
Lo := I - 1;
if (NF[Hi] - Freq) > (Freq - NF[Lo]) then
RF := NF[Lo] - Freq
else
RF := NF[Hi] - Freq;
Break;
end;
end;
Result := Frequency + RF;
end;
//------------------------------------------------------------------------------
function GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;
var
T0, T1: TULargeInteger;
CountFreq: TULargeInteger;
Freq, Freq2, Freq3, Total: Integer;
TotalCycles, Cycles: Int64;
Stamp0, Stamp1: Int64;
TotalTicks, Ticks: Cardinal;
Tries, Priority: Integer;
Thread: THandle;
begin
Stamp0 := 0;
Stamp1 := 0;
Freq := 0;
Freq2 := 0;
Freq3 := 0;
Tries := 0;
TotalCycles := 0;
TotalTicks := 0;
Total := 0;
Thread := GetCurrentThread();
Result := QueryPerformanceFrequency(Int64(CountFreq));
if Result then
begin
while ((Tries < 3 ) or ((Tries < 20) and ((Abs(3 * Freq - Total) > 3) or
(Abs(3 * Freq2 - Total) > 3) or (Abs(3 * Freq3 - Total) > 3)))) do
begin
Inc(Tries);
Freq3 := Freq2;
Freq2 := Freq;
QueryPerformanceCounter(Int64(T0));
T1.LowPart := T0.LowPart;
T1.HighPart := T0.HighPart;
Priority := GetThreadPriority(Thread);
if Priority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(Thread, THREAD_PRIORITY_TIME_CRITICAL);
try
while (T1.LowPart - T0.LowPart) < 50 do
begin
QueryPerformanceCounter(Int64(T1));
Stamp0 := ReadTimeStampCounter;
end;
T0.LowPart := T1.LowPart;
T0.HighPart := T1.HighPart;
while (T1.LowPart - T0.LowPart) < 1000 do
begin
QueryPerformanceCounter(Int64(T1));
Stamp1 := ReadTimeStampCounter;
end;
finally
if Priority <> THREAD_PRIORITY_ERROR_RETURN then
SetThreadPriority(Thread, Priority);
end;
Cycles := Stamp1 - Stamp0;
Ticks := T1.LowPart - T0.LowPart;
Ticks := Ticks * 100000;
Ticks := Round(Ticks / (CountFreq.LowPart / 10));
TotalTicks := TotalTicks + Ticks;
TotalCycles := TotalCycles + Cycles;
Freq := Round(Cycles / Ticks);
Total := Freq + Freq2 + Freq3;
end;
Freq3 := Round((TotalCycles * 10) / TotalTicks);
Freq2 := Round((TotalCycles * 100) / TotalTicks);
if Freq2 - (Freq3 * 10) >= 6 then
Inc(Freq3);
CpuSpeed.RawFreq := Round(TotalCycles / TotalTicks);
CpuSpeed.NormFreq := CpuSpeed.RawFreq;
Freq := CpuSpeed.RawFreq * 10;
if (Freq3 - Freq) >= 6 then
Inc(CpuSpeed.NormFreq);
CpuSpeed.ExTicks := TotalTicks;
CpuSpeed.InCycles := TotalCycles;
CpuSpeed.NormFreq := RoundFrequency(CpuSpeed.NormFreq);
Result := True;
end;
end;
//------------------------------------------------------------------------------
// Helper function for CPUID. Initializes Intel specific fields.
procedure IntelSpecific(var CpuInfo: TCpuInfo);
var
I: Integer;
begin
with CpuInfo do
begin
Manufacturer := 'Intel';
CpuType := CPU_TYPE_INTEL;
if HasCacheInfo then
with CPUInfo.IntelSpecific do
begin
L2Cache := 0;
for I := 1 to 15 do
case CacheDescriptors[I] of
$40:
L2Cache := 0;
$41:
L2Cache := 128;
$42:
L2Cache := 256;
$43:
L2Cache := 512;
$44:
L2Cache := 1024;
$45:
L2Cache := 2048;
end;
end;
if not HasExtendedInfo then
begin
case Family of
4:
case Model of
1:
CpuName := 'Intel 486DX Processor';
2:
CpuName := 'Intel 486SX Processor';
3:
CpuName := 'Intel DX2 Processor';
4:
CpuName := 'Intel 486 Processor';
5:
CpuName := 'Intel SX2 Processor';
7:
CpuName := 'Write-Back Enhanced Intel DX2 Processor';
8:
CpuName := 'Intel DX4 Processor';
else
CpuName := 'Intel 486 Processor';
end;
5:
CpuName := 'Pentium';
6:
case Model of
1:
CpuName := 'Pentium Pro';
3:
CpuName := 'Pentium II';
5:
case IntelSpecific.L2Cache of
0:
CpuName := 'Celeron';
1024:
CpuName := 'Pentium II Xeon';
2048:
CpuName := 'Pentium II Xeon';
else
CpuName := 'Pentium II';
end;
6:
case IntelSpecific.L2Cache of
0:
CpuName := 'Celeron';
128:
CpuName := 'Celeron';
else
CpuName := 'Pentium II';
end;
7:
case IntelSpecific.L2Cache of
1024:
CpuName := 'Pentium III Xeon';
2048:
CpuName := 'Pentium III Xeon';
else
CpuName := 'Pentium III';
end;
8:
case IntelSpecific.BrandID of
1: CpuName := 'Celeron';
2: CpuName := 'Pentium III';
3: CpuName := 'Pentium III Xeon';
4: CpuName := 'Pentium III';
else
CpuName := 'Pentium III';
end;
10:
CpuName := 'Pentium III Xeon';
11:
CpuName := 'Pentium III';
else
StrPCopy(CpuName, Format('P6 (Model %d)', [Model]));
end;
15:
case IntelSpecific.BrandID of
1:
CpuName := 'Celeron';
8:
CpuName := 'Pentium 4';
14:
CpuName := 'Xeon';
else
CpuName := 'Pentium 4';
end;
else
StrPCopy(CpuName, Format('P%d', [Family]));
end;
end;
end;
end;
//------------------------------------------------------------------------------
// Helper function for CPUID. Initializes Cyrix specific fields.
procedure CyrixSpecific(var CpuInfo: TCpuInfo);
begin
with CpuInfo do
begin
Manufacturer := 'Cyrix';
CpuType := CPU_TYPE_CYRIX;
if not HasExtendedInfo then
begin
case Family of
4:
CpuName := 'Cyrix MediaGX';
5:
case Model of
2:
CpuName := 'Cyrix 6x86';
4:
CpuName := 'Cyrix GXm';
end;
6:
CpuName := '6x86MX';
else
StrPCopy(CpuName, Format('%dx86', [Family]));
end;
end;
end;
end;
//------------------------------------------------------------------------------
// Helper function for CPUID. Initializes AMD specific fields.
procedure AMDSpecific(var CpuInfo: TCpuInfo);
begin
with CpuInfo do
begin
Manufacturer := 'AMD';
CpuType := CPU_TYPE_AMD;
if not HasExtendedInfo then
begin
case Family of
4:
CpuName := 'Am486(R) or Am5x86';
5:
case Model of
0:
CpuName := 'AMD-K5 (Model 0)';
1:
CpuName := 'AMD-K5 (Model 1)';
2:
CpuName := 'AMD-K5 (Model 2)';
3:
CpuName := 'AMD-K5 (Model 3)';
6:
CpuName := 'AMD-K6(R)';
7:
CpuName := 'AMD-K6';
8:
CpuName := 'AMD-K6(R) -2';
9:
CpuName := 'AMD-K6(R) -3';
else
CpuName := 'Unknown AMD Model';
end;
else
CpuName := 'Unknown AMD Chip';
end;
end;
end;
end;
//------------------------------------------------------------------------------
function CPUID: TCpuInfo;
var
CPUInfo: TCpuInfo;
HiVal: Cardinal;
TimesToExecute, CurrentLoop: Byte;
begin
asm
MOV [CPUInfo.HasInstruction], 0
MOV [CPUInfo.HasExtendedInfo], 0
MOV [CPUInfo.HasCacheInfo], 0
MOV [CPUInfo.PType], 0
MOV [CPUInfo.Model], 0
MOV [CPUInfo.Stepping], 0
MOV [CPUInfo.Features], 0
MOV [CPUInfo.FrequencyInfo.RawFreq], 0
MOV [CPUInfo.FrequencyInfo.NormFreq], 0
MOV [CPUInfo.FrequencyInfo.InCycles], 0
MOV [CPUInfo.FrequencyInfo.ExTicks], 0
MOV [CPUInfo.IntelSpecific.BrandID],0
PUSH EAX
PUSH EBP
PUSH EBX
PUSH ECX
PUSH EDI
PUSH EDX
PUSH ESI
@@Check80486:
MOV [CPUInfo.Family], 4
PUSHFD
POP EAX
MOV ECX, EAX
XOR EAX, 200000H
PUSH EAX
POPFD
PUSHFD
POP EAX
XOR EAX, ECX
JE @@DoneCpuType
@@HasCPUIDInstruction:
MOV [CPUInfo.HasInstruction], 1
MOV EAX, 0
DB 0FH
DB 0A2H
MOV HiVal, EAX
MOV DWORD PTR [CPUInfo.VendorIDString], EBX
MOV DWORD PTR [CPUInfo.VendorIDString + 4], EDX
MOV DWORD PTR [CPUInfo.VendorIDString + 8], ECX
@@CheckIntel:
CMP DWORD PTR [CPUInfo.VendorIDString], 'uneG'
JNE @@CheckAMD
CMP DWORD PTR [CPUInfo.VendorIDString + 4], 'Ieni'
JNE @@CheckAMD
CMP DWORD PTR [CPUInfo.VendorIDString + 8], 'letn'
JNE @@CheckAMD
MOV [CPUInfo.CpuType], CPU_TYPE_INTEL
JMP @@StandardFunctions
@@CheckAMD:
CMP DWORD PTR [CPUInfo.VendorIDString], 'htuA'
JNE @@CheckCitrix
CMP DWORD PTR [CPUInfo.VendorIDString + 4], 'itne'
JNE @@CheckCitrix
CMP DWORD PTR [CPUInfo.VendorIDString + 8], 'DMAc'
JNE @@CheckCitrix
MOV [CPUInfo.CpuType], CPU_TYPE_AMD
JMP @@CheckAMDExtended
@@CheckCitrix:
CMP DWORD PTR [CPUInfo.VendorIDString], 'iryC'
JNE @@StandardFunctions
CMP DWORD PTR [CPUInfo.VendorIDString + 4], 'snIx'
JNE @@StandardFunctions
CMP DWORD PTR [CPUInfo.VendorIDString + 8], 'daet'
JNE @@StandardFunctions
MOV [CPUInfo.CpuType], CPU_TYPE_CYRIX
JMP @@CheckCitrixExtended
@@CheckAMDExtended:
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@StandardFunctions
JMP @@AMDOnly
@@CheckCitrixExtended:
MOV EAX, 80000000h
DB 0Fh
DB 0A2h
CMP EAX, 0
JE @@StandardFunctions
JMP @@CitrixOnly
@@StandardFunctions:
CMP HiVal, 1
JL @@DoneCPUType
MOV EAX, 1
DB 0FH
DB 0A2H
MOV [CPUInfo.Features], EDX
MOV [CPUInfo.IntelSpecific.BrandID], BL
MOV ECX, EAX
AND EAX, 3000H
SHR EAX, 12
MOV [CPUInfo.PType], AL
MOV EAX, ECX
AND EAX, 0F00H
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, ECX
AND EAX, 00F0H
SHR EAX, 4
MOV [CPUInfo.MODEL], AL
MOV EAX, ECX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
CMP DWORD PTR [CPUInfo.VendorIDString], 'uneG'
JNE @@DoneCPUType
CMP DWORD PTR [CPUInfo.VendorIDString + 4], 'Ieni'
JNE @@DoneCPUType
CMP DWORD PTR [CPUInfo.VendorIDString + 8], 'letn'
JNE @@DoneCPUType
@@IntelStandard:
CMP HiVal, 2
JL @@DoneCPUType
MOV CurrentLoop, 0
MOV [CPUInfo.HasCacheInfo], 1
PUSH ECX
@@RepeatCacheQuery:
POP ECX
MOV EAX, 2
DB 0FH
DB 0A2H
INC CurrentLoop
CMP CurrentLoop, 1
JNE @@DoneCacheQuery
MOV TimesToExecute, AL
CMP AL, 0
JE @@DoneCPUType
@@DoneCacheQuery:
PUSH ECX
MOV CL, CurrentLoop
SUB CL, TimesToExecute
JNZ @@RepeatCacheQuery
POP ECX
MOV DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors], EAX
MOV DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors + 4], EBX
MOV DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors + 8], ECX
MOV DWORD PTR [CPUInfo.IntelSpecific.CacheDescriptors + 12], EDX
JMP @@DoneCPUType
@@AMDOnly:
MOV HiVal, EAX
MOV EAX, 80000001h
CMP HiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasExtendedInfo], 1
DB 0Fh
DB 0A2h
MOV ECX, EAX
AND EAX, 0F000H
SHR EAX, 12
MOV [CPUInfo.PType], AL
MOV EAX, ECX
AND EAX, 0F00H
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, ECX
AND EAX, 00F0H
SHR EAX, 4
MOV [CPUInfo.MODEL], AL
MOV EAX, ECX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
MOV [CPUInfo.Features], EDX
MOV EAX, 80000002h
CMP HiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName], EAX
MOV DWORD PTR [CPUInfo.CpuName + 4], EBX
MOV DWORD PTR [CPUInfo.CpuName + 8], ECX
MOV DWORD PTR [CPUInfo.CpuName + 12], EDX
MOV EAX, 80000003h
CMP HiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName + 16], EAX
MOV DWORD PTR [CPUInfo.CpuName + 20], EBX
MOV DWORD PTR [CPUInfo.CpuName + 24], ECX
MOV DWORD PTR [CPUInfo.CpuName + 28], EDX
MOV EAX, 80000004h
CMP HiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName + 32], EAX
MOV DWORD PTR [CPUInfo.CpuName + 36], EBX
MOV DWORD PTR [CPUInfo.CpuName + 40], ECX
MOV DWORD PTR [CPUInfo.CpuName + 44], EDX
MOV EAX, 80000005h
CMP HiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasCacheInfo], 1
DB 0Fh
DB 0A2h
MOV WORD PTR [CPUInfo.AMDSpecific.InstructionTLB], BX
SHR EBX, 16
MOV WORD PTR [CPUInfo.AMDSpecific.DataTLB], BX
MOV DWORD PTR [CPUInfo.AMDSpecific.L1DataCache], ECX
MOV DWORD PTR [CPUInfo.AMDSpecific.L1ICache], EDX
JMP @@DoneCPUType
@@CitrixOnly:
MOV HiVal, EAX
MOV EAX, 80000001h
CMP HiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasExtendedInfo], 1
DB 0Fh
DB 0A2h
MOV ECX, EAX
AND EAX, 0F000H
SHR EAX, 12
MOV [CPUInfo.PType], AL
MOV EAX, ECX
AND EAX, 0F00H
SHR EAX, 8
MOV [CPUInfo.Family], AL
MOV EAX, ECX
AND EAX, 00F0H
SHR EAX, 4
MOV [CPUInfo.MODEL], AL
MOV EAX, ECX
AND EAX, 000FH
MOV [CPUInfo.Stepping], AL
MOV [CPUInfo.Features], EDX
MOV EAX, 80000002h
CMP HiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName], EAX
MOV DWORD PTR [CPUInfo.CpuName + 4], EBX
MOV DWORD PTR [CPUInfo.CpuName + 8], ECX
MOV DWORD PTR [CPUInfo.CpuName + 12], EDX
MOV EAX, 80000003h
CMP HiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName + 16], EAX
MOV DWORD PTR [CPUInfo.CpuName + 20], EBX
MOV DWORD PTR [CPUInfo.CpuName + 24], ECX
MOV DWORD PTR [CPUInfo.CpuName + 28], EDX
MOV EAX, 80000004h
CMP HiVal, EAX
JL @@DoneCPUType
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CpuName + 32], EAX
MOV DWORD PTR [CPUInfo.CpuName + 36], EBX
MOV DWORD PTR [CPUInfo.CpuName + 40], ECX
MOV DWORD PTR [CPUInfo.CpuName + 44], EDX
MOV EAX, 80000005h
CMP HiVal, EAX
JL @@DoneCPUType
MOV [CPUInfo.HasCacheInfo], 1
DB 0Fh
DB 0A2h
MOV DWORD PTR [CPUInfo.CyrixSpecific.TLBInfo], EBX
MOV DWORD PTR [CPUInfo.CyrixSpecific.L1CacheInfo], ECX
@@DoneCpuType:
POP ESI
POP EDX
POP EDI
POP ECX
POP EBX
POP EBP
POP EAX
end;
if CPUInfo.VendorIDString = 'GenuineIntel' then
IntelSpecific(CpuInfo);
if CPUInfo.VendorIDString = 'CyrixInstead' then
CyrixSpecific(CpuInfo);
if CPUInfo.VendorIDString = 'AuthenticAMD' then
AMDSpecific(CpuInfo);
Result := CPUInfo;
end;
//------------------------------------------------------------------------------
function TestFDIVInstruction: Boolean;
var
TopNum: Double;
BottomNum: Double;
One: Double;
ISOK: Boolean;
begin
// The following code was found in Borlands fdiv.asm file in the
// Delphi 3\Source\RTL\SYS directory, (I made some minor modifications)
// therefore I cannot take credit for it.
TopNum := 2658955;
BottomNum := PI;
One := 1;
asm
PUSH EAX
FLD [TopNum]
FDIV [BottomNum]
FMUL [BottomNum]
FSUBR [TopNum]
FCOMP [One]
FSTSW AX
SHR EAX, 8
AND EAX, 01H
MOV ISOK, AL
POP EAX
end;
Result := ISOK;
end;
//==============================================================================
// Alloc granularity
//==============================================================================
procedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);
begin
if (Value mod AllocGranularity) <> 0 then
if Up then
Value := ((Value div AllocGranularity) + 1) * AllocGranularity
else
Value := (Value div AllocGranularity) * AllocGranularity;
end;
//------------------------------------------------------------------------------
procedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);
begin
if (Cardinal(Value) mod AllocGranularity) <> 0 then
if Up then
Value := Pointer(((Cardinal(Value) div AllocGranularity) + 1) * AllocGranularity)
else
Value := Pointer((Cardinal(Value) div AllocGranularity) * AllocGranularity);
end;
//==============================================================================
// Advanced Power Management (APM)
//==============================================================================
function GetAPMLineStatus: TAPMLineStatus;
var
SystemPowerstatus: TSystemPowerStatus;
begin
Result := alsUnknown;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
begin
case SystemPowerStatus.ACLineStatus of
0:
Result := alsOffline;
1:
Result := alsOnline;
255:
Result := alsUnknown;
end;
end;
end;
//------------------------------------------------------------------------------
function GetAPMBatteryFlag: TAPMBatteryFlag;
var
SystemPowerstatus: TSystemPowerStatus;
begin
Result := abfUnknown;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
begin
case SystemPowerStatus.BatteryFlag of
1:
Result := abfHigh;
2:
Result := abfLow;
4:
Result := abfCritical;
8:
Result := abfCharging;
128:
Result := abfNoBattery;
255:
Result := abfUnknown;
end;
end;
end;
//------------------------------------------------------------------------------
function GetAPMBatteryLifePercent: Integer;
var
SystemPowerstatus: TSystemPowerStatus;
begin
Result := 0;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
Result := SystemPowerStatus.BatteryLifePercent;
end;
//------------------------------------------------------------------------------
function GetAPMBatteryLifeTime: DWORD;
var
SystemPowerstatus: TSystemPowerStatus;
begin
Result := 0;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
Result := SystemPowerStatus.BatteryLifeTime;
end;
//------------------------------------------------------------------------------
function GetAPMBatteryFullLifeTime: DWORD;
var
SystemPowerstatus: TSystemPowerStatus;
begin
Result := 0;
if not GetSystemPowerStatus(SystemPowerStatus) then
RaiseLastOSError
else
Result := SystemPowerStatus.BatteryFullLifeTime;
end;
//==============================================================================
// Memory Information
//==============================================================================
function GetMaxAppAddress: Integer;
var
SystemInfo: TSystemInfo;
begin
FillChar(SystemInfo, SizeOf(SystemInfo), #0);
GetSystemInfo(SystemInfo);
Result := Integer(SystemInfo.lpMaximumApplicationAddress);
end;
//------------------------------------------------------------------------------
function GetMinAppAddress: Integer;
var
SystemInfo: TSystemInfo;
begin
FillChar(SystemInfo, SizeOf(SystemInfo), #0);
GetSystemInfo(SystemInfo);
Result := Integer(SystemInfo.lpMinimumApplicationAddress);
end;
//------------------------------------------------------------------------------
function GetMemoryLoad: Byte;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwMemoryLoad;
end;
//------------------------------------------------------------------------------
function GetSwapFileSize: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
with MemoryStatus do
Result := Trunc(dwTotalPageFile - dwAvailPageFile);
end;
//------------------------------------------------------------------------------
function GetSwapFileUsage: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
with MemoryStatus do
Result := 100 - Trunc(dwAvailPageFile / dwTotalPageFile * 100);
end;
//------------------------------------------------------------------------------
function GetTotalPhysicalMemory: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwTotalPhys;
end;
//------------------------------------------------------------------------------
function GetFreePhysicalMemory: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwAvailPhys;
end;
//------------------------------------------------------------------------------
function GetTotalPageFileMemory: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwTotalPageFile;
end;
//------------------------------------------------------------------------------
function GetFreePageFileMemory: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwAvailPageFile;
end;
//------------------------------------------------------------------------------
function GetTotalVirtualMemory: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwTotalVirtual;
end;
//------------------------------------------------------------------------------
function GetFreeVirtualMemory: Integer;
var
MemoryStatus: TMemoryStatus;
begin
FillChar(MemoryStatus, SizeOf(MemoryStatus), 0);
MemoryStatus.dwLength := SizeOf(MemoryStatus);
GlobalMemoryStatus(MemoryStatus);
Result := MemoryStatus.dwAvailVirtual;
end;
//==============================================================================
// Keyboard Information
//==============================================================================
function GetKeyState(const VirtualKey: Cardinal): boolean;
var
Keys: TKeyboardState;
begin
GetKeyBoardState(Keys);
Result := Keys[VirtualKey] and $80 <> 0;
end;
//------------------------------------------------------------------------------
function GetNumLockKeyState: boolean;
begin
Result := GetKeyState(VK_NUMLOCK);
end;
//------------------------------------------------------------------------------
function GetScrollLockKeyState: boolean;
begin
Result := GetKeyState(VK_SCROLL);
end;
//------------------------------------------------------------------------------
function GetCapsLockKeyState: boolean;
begin
Result := GetKeyState(VK_CAPITAL);
end;
//==============================================================================
// Initialization
//==============================================================================
procedure InitSysInfo;
var
SystemInfo: TSystemInfo;
Kernel32FileName: string;
begin
{ processor information related initialization }
FillChar(SystemInfo, SizeOf(SystemInfo), #0);
GetSystemInfo(SystemInfo);
ProcessorCount := SystemInfo.dwNumberOfProcessors;
AllocGranularity := SystemInfo.dwAllocationGranularity;
PageSize := SystemInfo.dwPageSize;
{ Windows version information }
KernelVersionHi := 0;
Kernel32FileName := GetModulePath(GetModuleHandle(kernel32));
if (not IsWinNT) and VersionResourceAvailable(Kernel32FileName) then
begin
with TJclFileVersionInfo.Create(Kernel32FileName) do
try
KernelVersionHi := FixedInfo.dwProductVersionMS;
finally
Free;
end
end;
IsWinNT := Win32Platform = VER_PLATFORM_WIN32_NT;
case GetWindowsVersion of
wvUnknown: ;
wvWin95:
IsWin95 := True;
wvWin95OSR2:
IsWin95OSR2 := True;
wvWin98:
IsWin98 := True;
wvWin98SE:
IsWin98SE := True;
wvWinME:
IsWinME := True;
wvWinNT3:
IsWinNT3 := True;
wvWinNT4:
IsWinNT4 := True;
wvWin2000:
IsWin2K := True;
wvWinXP:
IsWinXP := True;
end;
end;
initialization
InitSysInfo;
end.
