En esta sección de Código Fuente en Delphi vamos a mostrar cómo podemos detectar si nuestra app se está ejecutando en una máquina virtual o en un sistema nativo.

Para ello, he escrito esta pequeña app de ejemplo.

En este programa de ejemplo se utiliza una unidad llamada uVMCheck que pone a nuestra disposición las siguientes funciones que son las que nos van a permitir saber si nuestra app se está ejecutando en alguna de las múltiples máquinas virtuales que existen en el mercado:

• function IsRunningVMWare: Boolean; que nos permite conocer si nuestra app se está ejecutando en un sistema VMWare.
• function IsRunningWine: Boolean; que nos permite conocer si nuestra app se está ejecutando en un sistema Unix con el emulador de Windows Wine.
• function IsRunningVirtualPC: Boolean; que nos permite conocer si nuestra app se está ejecutando en Microsoft Virtual PC.
• function IsRunningVirtualBox: Boolean; que nos permite conocer si nuestra app se está ejecutando en Oracle VM VirtualBox.
• function IsRunningVM: Boolean; que nos permite saber si nuestra app se está ejecutando en una cualquiera de las máquinas virtuales anteriores.

Esta app necesita privilegios de administrador para ser ejecutada. Para que nuestra app adquiera estos derechos al ser arrancada se añade el archivo de recursos admin.rc que debe ser compilado con el compilador de recursos Brcc32.exe para generar el archivo admin.res que debe ser incluido en la Unit1.pas

En la siguiente imagen puedes ver un ejemplo de uso de esta app.

A continuación, puedes ver el código completo de la app, y si lo deseas puedes descargarlo todo (código y app) en un archivo "zip".

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Panel1: TPanel;
    RadioGroup1: TRadioGroup;
    procedure Label1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
{$R admin.res}

uses uVMCheck, shellapi;




procedure OpenUrl(url: string);
begin
  ShellExecute(Application.Handle, 'open', PChar(url), nil, nil, SW_SHOWMAXIMIZED);
end;


procedure TForm1.FormCreate(Sender: TObject);
begin
  if IsRunningVM then begin
    Label2.Caption := RadioGroup1.Items[1];
    RadioGroup1.ItemIndex := 1;
  end else begin
    Label2.Caption := RadioGroup1.Items[0];
    RadioGroup1.ItemIndex := 0;
  end;
end;

procedure TForm1.Label1Click(Sender: TObject);
begin
  OpenUrl((Sender as TLabel).Caption);
end;

end.

unit uVMCheck;

interface

type
  TVMWareVersion = (
    vvExpress,
    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',
    'VirtualBox');

function _IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;
function IsRunningVMWare: Boolean;
function _IsRunningWine(var AWineVersion: string): Boolean;
function IsRunningWine: Boolean;
function IsRunningVirtualPC: Boolean;
function _IsRunningVM(var AVMVersion: string): Boolean;
function IsRunningVirtualBox: Boolean;
function IsRunningVM: Boolean;

implementation

uses tlhelp32, SysUtils, Windows;

//Requiere ejecutar como administrador

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 IsRunningVirtualBox: Boolean;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  result := false;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while Integer(ContinueLoop) <> 0 do
  begin
    if (pos('vboxservice.exe', lowercase(FProcessEntry32.szExeFile)) > 0) then
    begin
      CloseHandle(FSnapshotHandle);
      result := true;
      exit;
    end;
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
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[vmVirtualPC]
      else
        if IsRunningVirtualBox 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.

La guía de Delphi. Francisco Charte

La guía de Delphi. Marco Cantú

Curso de Pascal por Nacho Cabanes

Introducción a la programación Pascal

Algoritmos y programación en Pascal

Manual de Pascal