Private Const VER_PLATFORM_WIN32_NT = 2

Private Type OSVERSIONINFO
  OSVSize         As Long 
  dwVerMajor      As Long 
  dwVerMinor      As Long 
  dwBuildNumber   As Long 
  PlatformID      As Long
  szCSDVersion    As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (lpVersionInformation As Any) As Long

Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const OPEN_EXISTING As Long = 3

Private Const IOCTL_STORAGE_GET_MEDIA_TYPES_EX As Long = &H2D0C04

Private Const FILE_DEVICE_CD_ROM As Long = &H2
Private Const FILE_DEVICE_DVD As Long = &H33

Private Const DRIVE_REMOVABLE As Long = 2
Private Const DRIVE_FIXED As Long = 3
Private Const DRIVE_REMOTE As Long = 4
Private Const DRIVE_CDROM As Long = 5
Private Const DRIVE_RAMDISK As Long = 6

Private Type DEVICE_MEDIA_INFO
 Cylinders As Double
 MediaType As Long
 TracksPerCylinder As Long
 SectorsPerTrack As Long
 BytesPerSector As Long
 NumberMediaSides As Long
 MediaCharacteristics As Long
End Type

Private Type GET_MEDIA_TYPES
 DeviceType As Long
 MediaInfoCount As Long
 MediaInfo(10) As DEVICE_MEDIA_INFO
End Type

Private Declare Function GetDriveType Lib "kernel32" _
     Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long
    
Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
     Alias "GetLogicalDriveStringsA" _
    (ByVal nBufferLength As Long, _
     ByVal lpBuffer As String) As Long
     
Private Declare Function CreateFile Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   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 hDrive 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 Sub Form_Load()

   Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
   Command1.Caption = "Get Drive/Media Type (all VB versions)"
   Command2.Caption = "Get Drive/Media Type (VB6 only)"
   
End Sub


Private Sub Form_DblClick()

   List1.Clear
   
End Sub


Private Sub Command1_Click()

  'VB4-32 / VB5 / VB6-compatible code
  
   Dim sAllDrives As String
   Dim sDrive As String
   Dim nDrvType As Long
 
  'get the list of all drives
   sAllDrives = GetDriveString()
 
  'separate the drive to
  'retrieve the drive type
   Do Until sAllDrives = Chr$(0)
   
     'strip off one drive
      sDrive = StripNulls(sAllDrives)
      
     'the next line is not required for the
     'code (the same call is made in
     'GetDrvDesc), but is included
     'in order to show the drive type returned
     'values in the listbox for this demo
      nDrvType = GetDriveTypeEx(sDrive)

      List1.AddItem sDrive & vbTab & nDrvType & vbTab & GetDrvDesc(sDrive)
      
   Loop
   
End Sub


Private Sub Command2_Click()

  'VB6-only

   Dim sAllDrives As String
   Dim nDrvType As Long
   Dim sDrives() As String
   Dim cnt As Long
   
  'get the list of all drives
   sAllDrives = GetDriveString()
   
  'Change nulls to spaces, then trim.
  'This is required as using Split()
  'with Chr$(0) alone adds two additional
  'entries to the array drives at the end
  'representing the terminating characters.
   sAllDrives = Replace$(sAllDrives, Chr$(0), Chr$(32))
   sDrives() = Split(Trim$(sAllDrives), Chr$(32))

   For cnt = LBound(sDrives) To UBound(sDrives)
      
     'the next line is not required for the
     'code (the same call is made in
     'GetDrvDesc), but is included
     'in order to show the drive type returned
     'values in the listbox for this demo
      nDrvType = GetDriveTypeEx(sDrives(cnt))

      List1.AddItem sDrives(cnt) & _
                    vbTab & _
                    nDrvType & _
                    vbTab & _
                    GetDrvDesc(sDrives(cnt))
      
   Next

End Sub


Private Function GetDrvDesc(RootPathName As String) As String
   
  'Used by both demos
  
  'Passed is the drive to check.
  'Returned is the type of drive.
   Select Case GetDriveType(RootPathName)
      Case 0: GetDrvDesc = "The drive type cannot be determined"
      Case 1: GetDrvDesc = "The root directory does not exist"

      Case DRIVE_REMOVABLE:
          Select Case Left$(RootPathName, 1)
              Case "a", "b": GetDrvDesc = "Floppy drive"
              Case Else: GetDrvDesc = "Removable drive"
          End Select

      Case DRIVE_FIXED:   GetDrvDesc = "Hard drive; can not be removed"
      Case DRIVE_REMOTE:  GetDrvDesc = "Remote (network) drive"
      Case DRIVE_CDROM:
      
           'a default description in case
           'the call below fails
            GetDrvDesc = "Optical Drive (CD or DVD)"
            
            Select Case GetDriveTypeEx(RootPathName)
               Case FILE_DEVICE_CD_ROM: GetDrvDesc = "CD-ROM drive"
               Case FILE_DEVICE_DVD: GetDrvDesc = "DVD drive"
            End Select
                                  
      Case DRIVE_RAMDISK: GetDrvDesc = "RAM disk"
   End Select

End Function


Private Function GetDriveString() As String

  'Used by both demos
  
  'returns string of available
  'drives each separated by a null
   Dim sBuffer As String
   
  'possible 26 drives, three characters
  'each plus a trailing null for each
  'drive letter and a terminating null
  'for the string
   sBuffer = Space$((26 * 4) + 1)
  
   If GetLogicalDriveStrings(Len(sBuffer), sBuffer) Then

     'just trim off the trailing spaces
      GetDriveString = Trim$(sBuffer)
      
   End If

End Function


Public Function GetDriveTypeEx(sDrive As String) As Long

   Dim tmp As Long
   
  'initial test
   GetDriveTypeEx = GetDriveType(sDrive)

  'if the drive type returned indicates a
  'CD (DRIVE_CDROM) perform a DeviceIoControl
  'test to determine if a CD or a DVD.
   If GetDriveTypeEx = DRIVE_CDROMThen
   
     'obtain the DeviceIoControl media
     'code for the drive
      GetDriveTypeEx = GetMediaType(sDrive)
      
   End If  
    
End Function


Private Function GetMediaType(sDrive As String) As Long

   Dim hDrive As Long
   Dim gmt As GET_MEDIA_TYPES
   Dim status As Long
   Dim returned As Long
   Dim mynull As Long

  'test for os - IOCTL_STORAGE_GET_MEDIA_TYPES_EX is XP or later only!
   If IsWinXPPlus() Then
   
      sDrive = UnQualifyPath(sDrive)

     'get a handle to the drive
      hDrive = CreateFile("\\.\" & UCase$(sDrive), _
                           GENERIC_READ Or GENERIC_WRITE, _
                           FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                           mynull, OPEN_EXISTING, 0, mynull)
                              
      If hDrive <> INVALID_HANDLE_VALUE Then
   
         status = DeviceIoControl(hDrive, _
                                  IOCTL_STORAGE_GET_MEDIA_TYPES_EX, _
                                  mynull, _
                                  0, _
                                  gmt, _
                                  2048, _
                                  returned, _
                                  ByVal 0)
                                     
         If status <> 0 Then

            GetMediaType = gmt.DeviceType
   
         End If  'status
      End If  'hDrive
 
      CloseHandle hDrive
      
   End If  'IsWinXPPlus

End Function


Private Function IsWinXPPlus() As Boolean

  'returns True if running Windows XP or later
   Dim osv As OSVERSIONINFO

   osv.OSVSize = Len(osv)

   If GetVersionEx(osv) = 1 Then
   
      IsWinXPPlus = (osv.PlatformID = VER_PLATFORM_WIN32_NT) And _
                    (osv.dwVerMajor >= 5 And osv.dwVerMinor >= 1)

   End If

End Function


Private Function StripNulls(startstr As String) As String

  'Used by VB4-32 / VB5 / VB6 Command1 demo only
 
  'Take a string separated by Chr$(0)
  'and split off 1 item, shortening the
  'string so next item is ready for removal.
   Dim pos As Long

   pos = InStr(startstr$, Chr$(0))
  
   If pos Then
   
      StripNulls = Mid$(startstr, 1, pos - 1)
      startstr = Mid$(startstr, pos + 1, Len(startstr))
   
   End If

End Function


Private Function UnQualifyPath(sPath As String) As String
 
   If Len(sPath) > 0 Then
   
      sPath = Trim$(sPath)
 
      If Right$(sPath, 1) = "\" Then
         UnQualifyPath = Left$(sPath, Len(sPath) - 1)
      Else
         UnQualifyPath = sPath
      End If
      
   Else
      UnQualifyPath = ""
   End If
   
End Function