Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Function: SerialHD
' Autor: Adrian Desanti (Dessa)
' Creditos: es una adaptacion a mis necesidades de una clase de Antonio Giuliana
' Agradecimientos: Karcrak (IsAdministrador)
' Requisitos : Windows NT + Administrador
' Rertorno: retorna el serial verdadero de Discos IDE o S-ATA conectados
' Serial verdadero: Es el que figura en la etiqueta del Disco y no cambia al formatear
' Fecha : V.2 Septiembre 2010
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function CheckTokenMembership Lib "ADVAPI32" (ByVal TokenHandle As Long, ByVal pSidToCheck As Long, ByRef IsMember As Boolean) As Long
Private Declare Function GetVersion Lib "KERNEL32" () As Long
Private Declare Function CreateFile Lib "KERNEL32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject 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, ByVal lpOverlapped As Long) As Long
Private Declare Sub ZeroMemory Lib "KERNEL32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
Private Type IDEREGS
bFeaturesReg As Byte: bSectorCountReg As Byte: bSectorNumberReg As Byte: bCylLowReg As Byte: bCylHighReg As Byte: bDriveHeadReg As Byte: bCommandReg As Byte: bReserved As Byte
End Type
Private Type SENDCMDINPARAMS
cBufferSize As Long: irDriveRegs As IDEREGS: bDriveNumber As Byte: bReserved(1 To 3) As Byte: dwReserved(1 To 4) As Long
End Type
Private Type DRIVERSTATUS
bDriveError As Byte: bIDEStatus As Byte: bReserved(1 To 2) As Byte: dwReserved(1 To 2) As Long
End Type
Private Type SENDCMDOUTPARAMS
cBufferSize As Long: DStatus As DRIVERSTATUS: bBuffer(1 To 512) As Byte
End Type
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As GUID) 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 SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
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 Sub Form_Load()
If (GetVersion And &HFF) > &H5 Then
If App.LogMode = 0 Then
MsgBox "En Vista o Seven ejecutar compilado en modo Administrador"
End
End If
End If
AutoRedraw = True
FontBold = True
Caption = ""
Print SerialHD()
End Sub
Public Function SerialHD() As String
If (GetVersion And &HFF) < 5 Then
SerialHD = "Sistema Operativo No válido"
Exit Function
End If
If IsAdministrador = False Then
SerialHD = "Se requiere usuario Administrador"
Exit Function
End If
Dim RetDiskCount As Long
RetDiskCount = DiskCount()
If RetDiskCount < 0 Then
SerialHD = "DiskCount No válido"
Exit Function
End If
Dim nDisco As Long
Dim hdh As Long
Dim hddfr As Byte
Dim hddln As Byte
Dim bin As SENDCMDINPARAMS
Dim bout As SENDCMDOUTPARAMS
Dim br As Long
Dim x As Byte
Dim s As String
For nDisco = 0 To RetDiskCount - 1 ' los ciclos del For serán solo la cantidad de "PhysicalDrive" conectados
hdh = CreateFile("\\.\PhysicalDrive" & nDisco, &H3, &H0, &H0, &H3, &H0, &H0)
If hdh = -1 Then
If nDisco = 0 Then
SerialHD = " IDE " & nDisco & " = " & "Error en CreateFile" & vbNewLine
Else
SerialHD = SerialHD & " IDE " & nDisco & " = " & "Error en CreateFile" & vbNewLine
End If
Else
hddfr = 21 ' Posicion en el buffer del SerialNumber
hddln = 20 ' Tamaño resrvado en el buffer para el SerialNumber
Call ZeroMemory(bin, Len(bin))
Call ZeroMemory(bout, Len(bout))
With bin
.bDriveNumber = nDisco
.cBufferSize = 512
With .irDriveRegs
If (nDisco And 1) Then
.bDriveHeadReg = &HB0
Else
.bDriveHeadReg = &HA0
End If
.bCommandReg = &HEC
.bSectorCountReg = 1
.bSectorNumberReg = 1
End With
End With
'DFP_RECEIVE_DRIVE_DATA = &H7C088
Call DeviceIoControl(hdh, &H7C088, bin, Len(bin), bout, Len(bout), br, 0)
s = ""
For x = hddfr To hddfr + hddln - 1 Step 2
If bout.bBuffer(x + 1) = 0 Then Exit For
s = s & Chr(bout.bBuffer(x + 1))
If bout.bBuffer(x) = 0 Then Exit For
s = s & Chr(bout.bBuffer(x))
Next x
Call CloseHandle(hdh)
If Trim$(s) <> "" Then
SerialHD = SerialHD & " IDE " & nDisco & " = " & Trim$(s) & vbNewLine
End If
End If
Next nDisco
End Function
Private Function DiskCount() As Long
Dim TGUID As GUID
Dim hDev As Long
Call IIDFromString(StrPtr("{53f56307-b6bf-11d0-94f2-00a0c91efb8b}"), TGUID)
'&H12 ===> DIGCF_PRESENT = &H10 Or DIGCF_DEVICEINTERFACE = &H2
hDev = SetupDiGetClassDevs(VarPtr(TGUID), &H0, &H0, &H12)
If hDev = -1 Then
DiskCount = -1
Exit Function
End If
Dim Cnt As Long
Dim DTA As SP_DEVICE_INTERFACE_DATA
DTA.cbSize = Len(DTA)
While Not (SetupDiEnumDeviceInterfaces(hDev, &H0, TGUID, Cnt, DTA) = &H0)
Cnt = Cnt + 1
Wend
Call SetupDiDestroyDeviceInfoList(hDev)
DiskCount = Cnt
End Function
Private Function IsAdministrador() As Boolean
Dim SID(1) As Currency
SID(0) = 36028797018964.0193@
SID(1) = 233646220.9056@
Call CheckTokenMembership(&H0, VarPtr(SID(0)), IsAdministrador)
End Function