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