IsVirtualPCPresent (no WMI) [Source]

[cobein]

Bueno aca va mi humilde aporte, es una implemetacion del codigo de MadAntrax sin utilizar WMI, le agregue una funcion mas para detectar Sun VirtualBox.

Codigo original: http://foro.elhacker.net/programacion_vb/source_isvirtualpcpresent_sistema_antivirtualpc-t218845.0.html

Código (vb) [Seleccionar] Expandir


'---------------------------------------------------------------------------------------
' Module      : mVM_Detect
' DateTime    : 02/07/2008 20:46
' Author      : Cobein
' Mail        : cobein27@hotmail.com
' WebPage     : http://cobein27.googlepages.com/vb6
' Purpose     : Detect Virtual Machines
' Usage       : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
'
' Reference   : http://foro.elhacker.net/programacion_vb/source_isvirtualpcpresent_sistema_antivirtualpc-t218845.0.html
'
' Credits     : This code is completely based on MadAntrax submission, I just implemented
'               a non WMI version.
'
' History     : 02/07/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit

Private Const INVALID_HANDLE_VALUE  As Long = (-1)
Private Const OPEN_EXISTING         As Long = 3
Private Const FILE_SHARE_READ       As Long = &H1
Private Const FILE_SHARE_WRITE      As Long = &H2

Private Const DIGCF_PRESENT         As Long = &H2
Private Const DIGCF_DEVICEINTERFACE As Long = &H10

Private Type STORAGE_DEVICE_NUMBER
    dwDeviceType                    As Long
    dwDeviceNumber                  As Long
    dwPartitionNumber               As Long
End Type

Private Type GUID
    Data1                           As Long
    Data2                           As Integer
    Data3                           As Integer
    Data4(0 To 7)                   As Byte
End Type

Private Type SP_DEVICE_INTERFACE_DATA
    cbSize                          As Long
    InterfaceClassGuid              As GUID
    flags                           As Long
    Reserved                        As Long
End Type

Private Type SP_DEVINFO_DATA
    cbSize                          As Long
    ClassGuid                       As GUID
    DevInst                         As Long
    Reserved                        As Long
End Type

Private Type SP_DEVICE_INTERFACE_DETAIL_DATA
    cbSize                          As Long
    strDevicePath                   As String * 260
End Type

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByVal ClassGuid As Long, ByVal Enumerator As Long, ByVal HwndParent As Long, ByVal flags As Long) As Long
Private Declare Function SetupDiEnumDeviceInterfaces Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByRef InterfaceClassGuid As GUID, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Long
Private Declare Function SetupDiGetDeviceInterfaceDetail Lib "setupapi.dll" Alias "SetupDiGetDeviceInterfaceDetailA" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, DeviceInterfaceDetailData As Any, ByVal DeviceInterfaceDetailDataSize As Long, ByRef RequiredSize As Long, DeviceInfoData As Any) As Long
Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Public Function IsVirtualPCPresent() As Boolean
    Dim lBitMask    As Long
    Dim i           As Long
    Dim sData       As String
   
    lBitMask = GetLogicalDrives
   
    For i = 0 To 25
        If (lBitMask Or 2 ^ i) = lBitMask Then
            sData = sData & UCase(GetPNPDeviceID(Chr$(65 + i)))
        End If
    Next

    Select Case True
        Case sData Like "*VIRTUAL*"
            IsVirtualPCPresent = True
        Case sData Like "*VBOX*"
            IsVirtualPCPresent = True
    End Select
   
End Function

Private Function GetPNPDeviceID(ByVal sDevice As String) As String
    Dim tGUID                               As GUID
    Dim hDevInfo                            As Long
    Dim tSP_DEVICE_INTERFACE_DATA           As SP_DEVICE_INTERFACE_DATA
    Dim tSP_DEVICE_INTERFACE_DETAIL_DATA    As SP_DEVICE_INTERFACE_DETAIL_DATA
    Dim tSP_DEVINFO_DATA                    As SP_DEVINFO_DATA
    Dim lDevNumb                            As Long
   
    lDevNumb = GetDeviceNumber("\\.\" & Left$(sDevice, 1) & ":")
    If lDevNumb = -1 Then Exit Function
   
    sDevice = Left$(sDevice, 1) & ":"
   
    With tGUID
        .Data2 = &HB6BF:        .Data3 = &H11D0&
        .Data4(0) = &H94&:      .Data4(1) = &HF2&
        .Data4(2) = &H0&:       .Data4(3) = &HA0&
        .Data4(4) = &HC9&:      .Data4(5) = &H1E&
        .Data4(6) = &HFB&:      .Data4(7) = &H8B&
       
        Select Case GetDriveType(sDevice)
            Case 2
                Dim sDosDev As String * 260
                Call QueryDosDevice(sDevice, sDosDev, 260)
                If InStr(sDosDev, "\Floppy") Then
                    .Data1 = &H53F56311
                Else
                    .Data1 = &H53F56307
                End If
            Case 3: .Data1 = &H53F56307
            Case 5: .Data1 = &H53F56308
        End Select
    End With
   
    hDevInfo = SetupDiGetClassDevs(VarPtr(tGUID), 0, 0, _
       DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)
    If hDevInfo = -1 Then Exit Function

    tSP_DEVICE_INTERFACE_DATA.cbSize = Len(tSP_DEVICE_INTERFACE_DATA)
   
    Dim lIndex  As Long
    Dim lSize   As Long
    Dim lReturn As Long
   
    Do
        If SetupDiEnumDeviceInterfaces(hDevInfo, 0, tGUID, _
           lIndex, tSP_DEVICE_INTERFACE_DATA) Then
           
            If SetupDiGetDeviceInterfaceDetail(hDevInfo, _
               tSP_DEVICE_INTERFACE_DATA, ByVal 0&, 0, lSize, ByVal 0&) = 0 Then
       
                If Not lSize = 0 Then
                    tSP_DEVICE_INTERFACE_DETAIL_DATA.cbSize = 5
                    tSP_DEVINFO_DATA.cbSize = Len(tSP_DEVINFO_DATA)
           
                    If SetupDiGetDeviceInterfaceDetail(hDevInfo, _
                       tSP_DEVICE_INTERFACE_DATA, tSP_DEVICE_INTERFACE_DETAIL_DATA, _
                       ByVal lSize, lReturn, tSP_DEVINFO_DATA) Then
                        If lDevNumb = _
                           GetDeviceNumber(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath) Then
                            Call SetupDiDestroyDeviceInfoList(hDevInfo)
                            GetPNPDeviceID = Left$(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath, _
                               lstrlen(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath))
                            Exit Function
                        End If
                    End If
                End If
            End If
            lIndex = lIndex + 1
        Else
            Exit Function
        End If
    Loop
    Call SetupDiDestroyDeviceInfoList(hDevInfo)
   
End Function

Private Function GetDeviceNumber(ByVal sDrive As String) As Long
    Dim hVolume                 As Long
    Dim lRetBytes               As Long
    Dim tSTORAGE_DEVICE_NUMBER  As STORAGE_DEVICE_NUMBER
   
    hVolume = CreateFile(sDrive, 0, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
       ByVal 0&, OPEN_EXISTING, 0, 0)
   
    GetDeviceNumber = -1
   
    If Not hVolume = INVALID_HANDLE_VALUE Then
        If DeviceIoControl(hVolume, &H2D1080, ByVal 0&, ByVal 0&, _
           tSTORAGE_DEVICE_NUMBER, Len(tSTORAGE_DEVICE_NUMBER), _
           lRetBytes, ByVal 0&) Then
            GetDeviceNumber = tSTORAGE_DEVICE_NUMBER.dwDeviceNumber
        End If
        Call CloseHandle(hVolume)
    End If
End Function



[‭‭‭‭jackl007]

y esto no hace lo mismo?
http://foro.elhacker.net/programacion_vb/source_isvirtualpcpresent_sistema_antivirtualpc-t218845.0.html;msg1037935#msg1037935
o depende de algo para funcionar?

[cobein]

Si, el fin del codigo es el mismo, si miras el titulo dice NO WMI (Windows Management Instrumentation), lo hice asi porque como comente en el post original de MadAntrax, tube problemas con WMI y cuentas restringidas.

[‭‭‭‭jackl007]

tube problemas con WMI y cuentas restringidas.

eso queria saber, osea ese codigo de mad no era fiable para todas las pcs? ....

[cobein]

En vista con cuenta de invitado obtengo un esto al intentar conectar WMI (error 70: Permission Denied)

[Mad Antrax]

Jaque-mate.

Tu código es más estable al no usar WMI, pero algo extenso (para mi gusto) si lo implementas en stubs o similares.

De todas formas, seguro que ay otro método más sencillo y sin utilizar WMI para detectarlo... hay que investigar más!!

--------------

Por cierto, puedes discriminar un poco más la función, me explico:

"*VIRTUAL*" = VirtualPC
"*VMWARE*" = VMWare
"*VBOX*" = VirtualBox

Puedes hacer que la función de vuelva un Integer, ejemplo:

Código (vb) [Seleccionar] Expandir

   Select Case True
        Case sData Like "*VIRTUAL*"
           IsVirtualPCPresent = 1
        Case sData Like "*VMWARE*"
           IsVirtualPCPresent = 2
        Case sData Like "*VBOX*"
            IsVirtualPCPresent = 3
        Case Else
            IsVirtualPCPresent = 0
    End Select

Así el usuari podrá determinar si finaliza su ejecución solo si nos encontramos en VMWARE o solo en VirtualPC, etc...

Saludos, muy buen código.

[cobein]

@||MadAntrax||

Gracias por el comentario, se que es un poco extenso pero queria mantenerlo entendible y fiel al original.

Creo que el metodo mas simple para hacer esto es leer el valor de la clave HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Services\Disk\Enum\0\   y compararla los los 3 patrones mencionados.
No lo probe con diferentes cuentas ni OSs pero por lo poco que vi funciona perfectamente.

Saludos y gracias por el feedback.


Edit:

Bueno Aca esta el codigo de la idea anterior

Código (vb) [Seleccionar] Expandir


'---------------------------------------------------------------------------------------
' Module      : mDetectVM
' DateTime    : 03/07/2008 07:32
' Author      : Cobein
' Mail        : cobein27@hotmail.com
' WebPage     : http://cobein27.googlepages.com/vb6
' Purpose     : Mini Virtual Machine detection module
' Usage       : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
'
' History     : 03/07/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
                                                                                     
Public Function IsVirtualPCPresent() As Long
    Dim lhKey       As Long
    Dim sBuffer     As String
    Dim lLen        As Long

    If RegOpenKeyEx(&H80000002, "SYSTEM\ControlSet001\Services\Disk\Enum", _
       0, &H20019, lhKey) = 0 Then
        sBuffer = Space$(255): lLen = 255
        If RegQueryValueEx(lhKey, "0", 0, 1, ByVal sBuffer, lLen) = 0 Then
            sBuffer = UCase(Left$(sBuffer, lLen - 1))
            Select Case True
                Case sBuffer Like "*VIRTUAL*":   IsVirtualPCPresent = 1
                Case sBuffer Like "*VMWARE*":    IsVirtualPCPresent = 2
                Case sBuffer Like "*VBOX*":      IsVirtualPCPresent = 3
            End Select
        End If
        Call RegCloseKey(lhKey)
    End If
End Function