unit uDGVMUtils;
interface
(*******************************************************************************
http://www.delphigeist.com/2011/01/udgvmutils-version-11-thanks-to-chee.html?m=1
uDGVMUtils -- is an attempt to create one of the best virtual machine
detector methods, feel free to contribute in any way you wish.
Version 1.1, 2010-01-15
Copyright© you are free to use it for comercial, private or both purposes
Contributors:
Dorin Duminica
Chee Meng
*******************************************************************************)
type
TVMWareVersion = (
vvExpress = 1,
vvESX,
vvGSX,
vvWorkstation,
vvUnknown,
vvNative);
const
VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (
'Express',
'ESX',
'GSX',
'Workstation',
'Unknown',
'Native');
type
TVirtualMachineType = (
vmNative,
vmVMWare,
vmWine,
vmVirtualPC,
vmVirtualBox);
const
VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (
'Native',
'VMWare',
'Wine',
'Virtual PC',
'Virtual Box');
function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;
function IsRunningVMWare: Boolean; overload;
function IsRunningWine(var AWineVersion: string): Boolean; overload;
function IsRunningWine: Boolean; overload;
function IsRunningVirtualPC: Boolean;
function IsRunningVBox: Boolean;
function IsRunningVM(var AVMVersion: string): Boolean; overload;
function IsRunningVM: Boolean; overload;
implementation
uses
SysUtils,
Windows;
function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;
const
CVMWARE_FLAG = $564D5868;
var
LFlag: Cardinal;
LVersion: Cardinal;
begin
LFlag := 0;
try
asm
push eax
push ebx
push ecx
push edx
mov eax, 'VMXh'
mov ecx, 0Ah
mov dx, 'VX'
in eax, dx
mov LFlag, ebx
mov LVersion, ecx
pop edx
pop ecx
pop ebx
pop eax
end;
except
// uncomment next two lines if you wish to see exception
// on E: Exception do
// ShowMessage(E.message);
end; // trye
if LFlag = CVMWARE_FLAG then begin
Result := True;
case LVersion of
1: AVMWareVersion := vvExpress;
2: AVMWareVersion := vvESX;
3: AVMWareVersion := vvGSX;
4: AVMWareVersion := vvWorkstation;
else
AVMWareVersion := vvUnknown;
end
end else begin
Result := False;
AVMWareVersion := vvNative;
end; // if LFlag = CVMWARE_FLAG then begin
end;
function IsRunningVMWare: Boolean;
var
LVMWareVersion: TVMWareVersion;
begin
Result := IsRunningVMWare(LVMWareVersion);
end;
function IsRunningWine(var AWineVersion: string): Boolean;
type
TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}
TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}
var
LHandle: THandle;
LWineGetVersion: TWineGetVersion;
LWineNTToUnixFileName: TWineNTToUnixFileName;
begin
Result := False;
AWineVersion := 'Unknown';
LHandle := LoadLibrary('ntdll.dll');
if LHandle > 32 then begin
LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');
LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');
if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin
Result := True;
if Assigned(LWineGetVersion) then
AWineVersion := StrPas(LWineGetVersion);
end; // if Assigned(LWineGetVersion) or ...
FreeLibrary(LHandle);
end; // if LHandle > 32 then begin
end;
function IsRunningWine: Boolean;
var
LWineVersion: string;
begin
Result := IsRunningWine(LWineVersion);
end;
function IsRunningVirtualPC: Boolean;
asm
push ebp;
mov ebp, esp;
mov ecx, offset @exception_handler;
push ebx;
push ecx;
push dword ptr fs:[0];
mov dword ptr fs:[0], esp;
mov ebx, 0; // Flag
mov eax, 1; // VPC function number
// call VPC
db $0F, $3F, $07, $0B
mov eax, dword ptr ss:[esp];
mov dword ptr fs:[0], eax;
add esp, 8;
test ebx, ebx;
setz al;
lea esp, dword ptr ss:[ebp-4];
mov ebx, dword ptr ss:[esp];
mov ebp, dword ptr ss:[esp+4];
add esp, 8;
jmp @ret1;
@exception_handler:
mov ecx, [esp+0Ch];
mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running
add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC
xor eax, eax; // exception is handled
@ret1:
end;
function IsRunningVBox: Boolean;
function Test1: Boolean;
var
LHandle: Cardinal;
begin
Result := False;
try
LHandle := LoadLibrary('VBoxHook.dll');
Result := (LHandle <> 0);
if Result then
FreeLibrary(LHandle);
except
end; // trye
end; // function Test1: Boolean;
function Test2: Boolean;
var
LHandle: Cardinal;
begin
Result := False;
try
LHandle := CreateFile(
'\\\\.\\\VBoxMiniRdrDN',
GENERIC_READ,
FILE_SHARE_READ,
NIL,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
Result := (LHandle <> INVALID_HANDLE_VALUE);
if Result then
CloseHandle(LHandle);
except
end; // trye
end; // function Test2: Boolean;
begin
Result := Test1 or Test2;
end;
function IsRunningVM(var AVMVersion: string): Boolean;
begin
AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
Result := True;
if IsRunningWine then
AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
else
if IsRunningVMWare then
AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]
else
if IsRunningVirtualPC then
AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
else
if IsRunningVBox then
AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualBox]
else begin
AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
Result := False;
end;
end;
function IsRunningVM: Boolean;
var
LVMVersion: string;
begin
Result := IsRunningVM(LVMVersion);
end;
end.
