Attribute VB_Name = "GetIdeInfo"
Option Explicit
Option Base 0
'============================================================
Private Declare Sub MemCpy Lib "KERNEL32" Alias "RtlMoveMemory" _
    ByVal hpvDest As Any, ByVal hpvSource As Any, ByVal cbCopy 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, _
    ByVal lpInBuffer As Long, _
    ByVal nInBufferSize As Long, _
    ByVal lpOutBuffer As Long, _
    ByVal nOutBufferSize As Long, _
    ByRef lpBytesReturned As Long, _
    ByVal lpOverlapped As Long) As Long

Private Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyA" _
    ByVal lpString1 As String, ByVal lpString2 As Long) As Long

Private Declare Function FormatMessage Lib "KERNEL32" _
  Alias "FormatMessageA" _
  ByVal dwFlags As Long, ByVal lpSource As Long, _
  ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
  lpBuffer As Long, ByVal nSize As Long, _
  ByVal Arguments As Long) As Long
Private Declare Function GetLastError Lib "KERNEL32" () As Long
'============================================================
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100&
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200&
Private Const FORMAT_MESSAGE_FROM_STRING = &H400&
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800&
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000&
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF&
'============================================================
Private Type SrbIoControl
  HeaderLength  As Long
  Signature(7)  As Byte
  Timeout       As Long
  ControlCode   As Long
  ReturnCode    As Long
  Length        As Long
End Type 'len=28

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 'len=8

Public Type IDEInfo
  serial_number     As String
  firmware          As String
  model_number      As String
End Type

Private Type SendCmdInParams
  cBufferSize       As Long
  irDriveRegs       As IDERegs
  bDriveNumber      As Byte
  bReserved(2)      As Byte
  dwReserved(3)     As Long
  bBuffer(0) As Byte
End Type 'len=26+len(Buffer)

Private Buffer()     As Byte
Dim buffin()        As Byte
Dim buffout()       As Byte

Private Function ReverseOrderByte(buffin() As Byte, buffout() As Byte)
Dim i As Integer
Dim bufflen As Integer
  bufflen = UBound(buffin) + 1
  ReDim buffout(bufflen - 1)
  For i = 0 To (bufflen) - 1 Step 2
    buffout(i) = buffin(i + 1)
    buffout(i + 1) = buffin(i)
  Next
End Function

Private Function GetInfo(offset As Integer, leninfo As Integer) As String
Dim str As String
  ReDim buffin(leninfo - 1)
  MemCpy VarPtr(buffin(0)), VarPtr(Buffer(offset)), UBound(buffin) + 1
  ReverseOrderByte buffin, buffout
  str = String(UBound(buffin) + 1, " "
  MemCpy str, VarPtr(buffout(0)), UBound(buffin) + 1
  str = LTrim(str)
  str = RTrim(str)
  GetInfo = str
End Function

Private Sub PrintErrorMessage(ErrCode As Long, Optional MyStr As String)
Dim StrErr As String
Dim MyFlags As Long
Dim MyPtr As Long
Dim MyBuff() As Byte
Dim i As Long
    
    StrErr = String(255, " "
    MyFlags = FORMAT_MESSAGE_FROM_SYSTEM Or _
        FORMAT_MESSAGE_IGNORE_INSERTS Or _
        FORMAT_MESSAGE_ALLOCATE_BUFFER
    i = FormatMessage(MyFlags, vbNull, ErrCode, 0, MyPtr, 0, vbNull)
    If i = 0 Then
        StrErr = "Unknow Error!"
    Else
        ReDim Preserve MyBuff(1 To i)
    lstrcpy StrErr, MyPtr
    StrErr = Left(StrErr, i - 2)
    End If
    MsgBox StrErr & " Error Code #" & ErrCode & " " & MyStr, vbCritical
End Sub

Public Function GetInfoIDE() As IDEInfo
Dim Scsi            As String   'scsi channel nunber
Dim DriveNumber     As Integer  'scsi drive number
Dim DataSize        As Integer
Dim BufferSize      As Integer
Dim srbControl      As SrbIoControl
Dim SendCmdInParams As SendCmdInParams
Dim hDevice         As Long
Dim cbBytesReturned As Long
Dim retval          As Long
Dim str             As String
  Scsi = "0"
  hDevice = CreateFile("\\.\Scsi" & Scsi & ":", _
    &H40000000 Or &H80000000, &H1 Or &H2, 0, 3, 0, 0)
  If hDevice = -1 Then PrintErrorMessage Err.LastDllError, "Point#1": End
  riveNumber = 0
  ataSize = Len(SendCmdInParams) - 1 + 512
  BufferSize = Len(srbControl) + DataSize
  ReDim Buffer(BufferSize - 1)
  srbControl.HeaderLength = Len(srbControl)
  MemCpy VarPtr(srbControl.Signature(0)), "SCSIDISK", 8
  srbControl.Timeout = 2
  srbControl.ControlCode = &H1B0501
  srbControl.Length = DataSize
  With SendCmdInParams
    .cBufferSize = 512
    .bDriveNumber = DriveNumber
    With .irDriveRegs
      .bFeaturesReg = 0
      .bSectorCountReg = 1
      .bSectorNumberReg = 1
      .bCylLowReg = 0
      .bCylHighReg = 0
      .bDriveHeadReg = &HA0 Or ((DriveNumber And 1) * 8 ^ 4)
      .bCommandReg = &HEC
     End With
  End With
  MemCpy VarPtr(Buffer(0)), VarPtr(srbControl.HeaderLength), Len(srbControl)
  MemCpy VarPtr(Buffer(Len(srbControl))), VarPtr(SendCmdInParams.cBufferSize), _
    Len(SendCmdInParams)
  retval = DeviceIoControl(hDevice, &H4D008, VarPtr(Buffer(0)), BufferSize, _
    VarPtr(Buffer(0)), BufferSize, cbBytesReturned, 0)
  If retval = 0 Then PrintErrorMessage Err.LastDllError, "Point#2": End
  CloseHandle (hDevice)
  str = GetInfo(64, 20)
    GetInfoIDE.serial_number = str
  str = GetInfo(90, 8)
    GetInfoIDE.firmware = str
  str = GetInfo(98, 40)
    GetInfoIDE.model_number = str
End Function