'---------------------------------------------------------------------------------------
' 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
 
 

'---------------------------------------------------------------------------------------
' 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