VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDrive"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"No"
Option Explicit

Private Const MaxLen = 255

' Type declarations for API calls
Private Type MCI_OPEN_PARMS
    dwCallback As Long
    wDeviceID As Long
    lpstrDeviceType As String
    lpstrElementName As String
    lpstrAlias As String
End Type

'Private Type LARGE_INTEGER
'    LowPart As Long
'    HighPart As Long
'End Type
'
'Private Type SHQUERYRBINFO
'    cbSize As Long
'    i64Size As LARGE_INTEGER
'    i64NumItems As LARGE_INTEGER
'End Type

' Enumerations
Public Enum DriveTypeEnum
    dtAll = 0
    dtInvalid = 1
    dtFloppy = 2
    dtFixed = 3
    dtCD = 5
End Enum

Private Enum SpaceEnum
    seFree
    seUsed
    seTotal
End Enum

' API
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
'Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As LARGE_INTEGER, lpTotalNumberOfBytes As LARGE_INTEGER, lpTotalNumberOfFreeBytes As LARGE_INTEGER) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As Long, ByRef dwParam2 As Any) As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function SetVolumeLabel Lib "kernel32" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long


' METHODS


' Close drive door
Public Sub CloseDoor(Optional ByVal Drive As String = "(default)")
    If Drive = "(default)" Then
        mciSendString "Set CDAudio Door Closed", 0&, 0&, 0&
    Else
        OpenDriveDoor Drive, False
    End If
End Sub

' Eject CD/DVD
Public Sub Eject(Optional ByVal Drive As String = "(default)")
    If Drive = "(default)" Then
        mciSendString "Set CDAudio Door Open", 0&, 0&, 0&
    Else
        OpenDriveDoor Drive
    End If
End Sub

' Populate a 1-base array with drive designations
' for all drive types. Return number of drives found.
Public Function EnumerateAll(Drives() As String) As Long
    Dim i As Long
    Dim strBuffer As String
    Dim strDrive As String

    ReDim Drives(1 To 1)
    strBuffer = Space$(255)
    strBuffer = Left$(strBuffer, GetLogicalDriveStrings(255, ByVal strBuffer))
    Do While InStr(strBuffer, "\")
        strDrive = Left$(strBuffer, InStr(strBuffer, "\") - 1)
        i = i + 1
        ReDim Preserve Drives(1 To i)
        Drives(i) = strDrive
        strBuffer = Mid$(strBuffer, Len(strDrive) + 3)
    Loop
    If Drives(1) = "" Then
        Erase Drives
        EnumerateAll = 0
    Else
        EnumerateAll = i
    End If
End Function

' Populate a 1-base array with drive designations for
' all CD and DVD drives. Return number of drives found.
Public Function EnumerateCDs(Drives() As String) As Long
    Dim i As Long
    Dim strBuffer As String
    Dim strDrive As String

    ReDim Drives(1 To 1)
    strBuffer = Space$(255)
    strBuffer = Left$(strBuffer, GetLogicalDriveStrings(255, ByVal strBuffer))
    Do While InStr(strBuffer, "\")
        strDrive = Left$(strBuffer, InStr(strBuffer, "\") - 1)
        If GetDriveType(strDrive) = dtCD Then
            i = i + 1
            ReDim Preserve Drives(1 To i)
            Drives(i) = strDrive
        End If
        strBuffer = Mid$(strBuffer, Len(strDrive) + 3)
    Loop
    If Drives(1) = "" Then
        Erase Drives
        EnumerateCDs = 0
    Else
        EnumerateCDs = i
    End If
End Function

' Populate a 1-base array with drive designations for
' all harddrives. Return number of drives found.
Public Function EnumerateFixed(Drives() As String) As Long
    Dim i As Long
    Dim strBuffer As String
    Dim strDrive As String

    ReDim Drives(1 To 1)
    strBuffer = Space$(255)
    strBuffer = Left$(strBuffer, GetLogicalDriveStrings(255, ByVal strBuffer))
    Do While InStr(strBuffer, "\")
        strDrive = Left$(strBuffer, InStr(strBuffer, "\") - 1)
        If GetDriveType(strDrive) = dtFixed Then
            i = i + 1
            ReDim Preserve Drives(1 To i)
            Drives(i) = strDrive
        End If
        strBuffer = Mid$(strBuffer, Len(strDrive) + 3)
    Loop
    If Drives(1) = "" Then
        Erase Drives
        EnumerateFixed = 0
    Else
        EnumerateFixed = i
    End If
End Function

' Populate a 1-base array with drive designations for
' all floppy drives. Return number of drives found.
Public Function EnumerateFloppies(Drives() As String) As Long
    Dim i As Long
    Dim strBuffer As String
    Dim strDrive As String

    ReDim Drives(1 To 1)
    strBuffer = Space$(255)
    strBuffer = Left$(strBuffer, GetLogicalDriveStrings(255, ByVal strBuffer))
    Do While InStr(strBuffer, "\")
        strDrive = Left$(strBuffer, InStr(strBuffer, "\") - 1)
        If GetDriveType(strDrive) = dtFloppy Then
            i = i + 1
            ReDim Preserve Drives(1 To i)
            Drives(i) = strDrive
        End If
        strBuffer = Mid$(strBuffer, Len(strDrive) + 3)
    Loop
    If Drives(1) = "" Then
        Erase Drives
        EnumerateFloppies = 0
    Else
        EnumerateFloppies = i
    End If
End Function

Public Function FormatSize(ByVal Size As Currency) As String
    Const Kilobyte As Currency = 1024@
    Const HundredK As Currency = 102400@
    Const ThousandK As Currency = 1024000@
    Const Megabyte As Currency = 1048576@
    Const HundredMeg As Currency = 104857600@
    Const ThousandMeg As Currency = 1048576000@
    Const Gigabyte As Currency = 1073741824@
    Const Terabyte As Currency = 1099511627776@
    
    If Size < Kilobyte Then
        FormatSize = Int(Size) & " bytes"
    ElseIf Size < HundredK Then
        FormatSize = Format(Size / Kilobyte, "#.0") & " KB"
    ElseIf Size < ThousandK Then
        FormatSize = Int(Size / Kilobyte) & " KB"
    ElseIf Size < HundredMeg Then
        FormatSize = Format(Size / Megabyte, "#.0") & " MB"
    ElseIf Size < ThousandMeg Then
        FormatSize = Int(Size / Megabyte) & " MB"
    ElseIf Size < Terabyte Then
        FormatSize = Format(Size / Gigabyte, "#.00") & " GB"
    Else
        FormatSize = Format(Size / Terabyte, "#.00") & " TB"
    End If
End Function

Public Sub GetDriveSpace(ByVal Drive As String, ByRef TotalSpace As Currency, ByRef FreeSpace As Currency, ByRef UsedSpace As Currency)
    Dim lngSectors As Long
    Dim lngBytes As Long
    Dim lngFree As Long
    Dim lngUsed As Long
    Dim lngTotal As Long
    Dim curCluster As Long
    
    Drive = Left$(Drive, 1) & ":\"
    GetDiskFreeSpace Drive, lngSectors, lngBytes, lngFree, lngTotal
    curCluster = CCur(lngBytes) * CCur(lngSectors)
    FreeSpace = curCluster * CCur(lngFree)
    UsedSpace = curCluster * CCur(lngTotal - lngFree)
    TotalSpace = curCluster * CCur(lngTotal)
End Sub

' Get free space on drive in bytes
Public Function GetFreeSpace(ByVal Drive As String) As Currency
    GetFreeSpace = GetSpace(Drive, seFree)
End Function

' Get total size of drive in bytes
Public Function GetTotalSpace(ByVal Drive As String) As Currency
    GetTotalSpace = GetSpace(Drive, seTotal)
End Function

' Get used space on drive in bytes
Public Function GetUsedSpace(ByVal Drive As String) As Currency
    GetUsedSpace = GetSpace(Drive, seUsed)
End Function

' Get the drive file system type (eg: NTFS)
Public Function GetFileSystem(ByVal Drive As String) As String
    Dim lngSerial As Long
    Dim strLabel As String * MaxLen
    Dim strFileSystem As String * MaxLen
    
    Drive = Left$(Drive, 1) & ":\"
    ' Get the volume information
    If GetVolumeInformation(Drive, strLabel, MaxLen, lngSerial, 0, 0, strFileSystem, MaxLen) Then
        GetFileSystem = Left$(strFileSystem, InStr(strFileSystem, vbNullChar) - 1)
    End If
End Function

' Get volume label
Public Function GetName(ByVal Drive As String) As String
    Dim lngSerial As Long
    Dim strLabel As String * MaxLen
    Dim strFileSystem As String * MaxLen
    
    Drive = Left$(Drive, 1) & ":\"
    ' Get the volume information
    If GetVolumeInformation(Drive, strLabel, MaxLen, lngSerial, 0, 0, strFileSystem, MaxLen) Then
        GetName = Left$(strLabel, InStr(strLabel, vbNullChar) - 1)
    End If
End Function

' Get the drive serial number
Public Function GetSerialNumber(ByVal Drive As String) As Long
    Dim lngSerial As Long
    Dim strLabel As String * MaxLen
    Dim strFileSystem As String * MaxLen
    
    Drive = Left$(Drive, 1) & ":\"
    ' Get the volume information
    If GetVolumeInformation(Drive, strLabel, MaxLen, lngSerial, 0, 0, strFileSystem, MaxLen) Then
        GetSerialNumber = lngSerial
    End If
End Function

' Get type (Floppy, Fixed, CD)
Public Function GetType(ByVal Drive As String) As DriveTypeEnum
    Dim lngTemp As Long
    
    Drive = Left$(Drive, 1) & ":"
    GetType = GetDriveType(Drive)
End Function

' Set volume label
Public Sub SetName(ByVal Drive As String, ByVal Label As String)
    Drive = Left$(Drive, 1) & ":\"
    SetVolumeLabel Drive, Label
End Sub



' INTERNAL FUNCTIONS


Private Function GetSpace(ByVal pstrDrive As String, penStat As SpaceEnum) As Currency
    Dim lngSectors As Long
    Dim lngBytes As Long
    Dim lngFree As Long
    Dim lngUsed As Long
    Dim lngTotal As Long
    Dim curCluster As Long
    
    pstrDrive = Left$(pstrDrive, 1) & ":\"
    GetDiskFreeSpace pstrDrive, lngSectors, lngBytes, lngFree, lngTotal
    curCluster = CCur(lngBytes) * CCur(lngSectors)
    Select Case penStat
        Case seFree: GetSpace = curCluster * CCur(lngFree)
        Case seUsed: GetSpace = curCluster * CCur(lngTotal - lngFree)
        Case seTotal: GetSpace = curCluster * CCur(lngTotal)
    End Select
End Function

Private Sub OpenDriveDoor(ByVal pstrDrive As String, Optional pblnOpen As Boolean = True)
    Const MCI_OPEN = &H803
    Const MCI_OPEN_TYPE = &H2000&
    Const MCI_OPEN_SHAREABLE = &H100&
    Const MCI_OPEN_ELEMENT As Long = &H200&
    Const MCI_SET = &H80D
    Const MCI_SET_DOOR_OPEN = &H100&
    Const MCI_SET_DOOR_CLOSED = &H200&
    Const MCI_CLOSE = &H804
    Dim typMCI As MCI_OPEN_PARMS
    Dim lngError As Long
    Dim strBuffer As String
    
    pstrDrive = Left$(pstrDrive, 1) & ":"
    If GetDriveType(pstrDrive) = dtCD Then
        typMCI.wDeviceID = 0
        typMCI.lpstrDeviceType = "cdaudio"
        typMCI.lpstrElementName = pstrDrive
        lngError = mciSendCommand(0, MCI_OPEN, MCI_OPEN_TYPE Or MCI_OPEN_SHAREABLE Or MCI_OPEN_ELEMENT, typMCI)
        If lngError = 0 Then
            If pblnOpen Then
                lngError = mciSendCommand(typMCI.wDeviceID, MCI_SET, MCI_SET_DOOR_OPEN, ByVal 0&)
            Else
                lngError = mciSendCommand(typMCI.wDeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, ByVal 0&)
            End If
            mciSendCommand typMCI.wDeviceID, MCI_CLOSE, 0&, 0&
        End If
        If lngError <> 0 Then
            strBuffer = Space$(255)
            mciGetErrorString lngError, strBuffer, Len(strBuffer)
            strBuffer = Trim$(strBuffer)
            MsgBox strBuffer, vbInformation, "Notice"
        End If
    End If
End Sub