VBA/Excel/Access/Word/File Path/Drive

Display Drive information

 
Sub cmdDriveInfo_Click()
    Dim myFileSystemObject As FileSystemObject, aDrive As Drive
    Set myFileSystemObject = New FileSystemObject
    Set aDrive = myFileSystemObject.GetDrive("C:\")
    With aDrive
        Debug.Print "Volume Name: " & .VolumeName & vbCrLf
        Debug.Print "Free Space: " & Format(.FreeSpace / 1000000000#, "#0.00") & "GB" & vbCrLf
        Debug.Print "Total Size: " & Format(.TotalSize / 1000000000#, "#0.00") & "GB" & vbCrLf
        Debug.Print "Ready: " & .IsReady
    End With
    Set myFileSystemObject = Nothing
    Set aDrive = Nothing
End Sub
Private Sub AddFolders()

Get Drive Information

 
Declare Function abGetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function abGetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
"The GetDriveInfo Procedure
Sub GetDriveInfo()
   Dim intDrive As Integer
   Dim strDriveLetter As String
   Dim strDriveType As String
   Dim strSpaceFree As String
   "Loop through all drives
   For intDrive = 65 To 90 "A through Z
     strDriveLetter = (Chr(intDrive) & ":\")
     "Get Drive Type
     strDriveType = TypeOfDrive(strDriveLetter)
     "Get Space Free
     strSpaceFree = NumberOfBytesFree(strDriveLetter)
     Debug.Print Left(strDriveLetter, 2) & _
         " - " & strDriveType & _
         IIf(strDriveType <> "Drive Doesn"t Exist", _
            strSpaceFree, "") & _
         vbCrLf
   Next intDrive
End Sub

Returns a string that describes the drive type

 
Private Declare Function GetDriveType32 Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Function DriveType(DriveLetter As String) As String
    DLetter = Left(DriveLetter, 1) & ":"
    DriveCode = GetDriveType32(DLetter)
    Select Case DriveCode
        Case 1: DriveType = "Local"
        Case 2: DriveType = "Removable"
        Case 3: DriveType = "Fixed"
        Case 4: DriveType = "Remote"
        Case 5: DriveType = "CD-ROM"
        Case 6: DriveType = "RAM Disk"
        Case Else: DriveType = "Unknown Drive Type"
    End Select
End Function
Sub Main()
  Debug.Print DriveType("c:\")
End Sub

Returns the drive letter using an index

 
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function DriveName(index As Integer) As String
    Dim Buffer As String * 255
    Dim BuffLen As Long
    Dim TheDrive As String
    Dim DriveCount As Integer
   
    BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
    TheDrive = ""
    DriveCount = 0
    For i = 1 To BuffLen
        If Asc(Mid(Buffer, i, 1)) <> 0 Then _
          TheDrive = TheDrive & Mid(Buffer, i, 1)
        If Asc(Mid(Buffer, i, 1)) = 0 Then "null separates drives
            DriveCount = DriveCount + 1
            If DriveCount = index Then
                DriveName = UCase(Left(TheDrive, 1))
                Exit Function
            End If
            TheDrive = ""
        End If
    Next i
End Function
Sub Main()
  Debug.Print DriveName(3)
End Sub

Returns the number of drives

 
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function NumberofDrives() As Integer
    Dim Buffer As String * 255
    Dim BuffLen As Long
    Dim DriveCount As Integer
   
    BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
    DriveCount = 0
    For i = 1 To BuffLen
        If Asc(Mid(Buffer, i, 1)) = 0 Then _
          DriveCount = DriveCount + 1
    Next i
    NumberofDrives = DriveCount
End Function
Sub Main()
  Debug.Print NumberofDrives
End Sub

Returns the number of free bytes for a drive

 
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Sub FreeDiskSpace()
    Dim SectorsPerCluster As Long
    Dim BytesPerSector As Long
    Dim NumberofFreeClusters As Long
    Dim TotalClusters As Long
    x = GetDiskFreeSpace("c:\", SectorsPerCluster, _
      BytesPerSector, NumberofFreeClusters, TotalClusters)
    
    If x = 0 Then "Error occurred
        Exit Sub
    End If
    Debug.Print SectorsPerCluster
    Debug.Print BytesPerSector
    Debug.Print NumberofFreeClusters
End Sub

Returns the total storage capacity for a drive

 
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Sub TotalDiskSpace()
    Dim SectorsPerCluster As Long
    Dim BytesPerSector As Long
    Dim NumberofFreeClusters As Long
    Dim TotalClusters As Long
    x = GetDiskFreeSpace("c:\", SectorsPerCluster, _
      BytesPerSector, NumberofFreeClusters, TotalClusters)
    
    If x = 0 Then "Error occurred
        
        Exit Sub
    End If
    Debug.Print SectorsPerCluster
    Debug.Print BytesPerSector
    Debug.Print TotalClusters
End Sub

Returns True if a specified drive letter exists

 
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Function DriveExists(DriveLetter As String) As Boolean
    Dim Buffer As String * 255
    Dim BuffLen As Long
   
    DLetter = Left(DriveLetter, 1)
    BuffLen = GetLogicalDriveStrings(Len(Buffer), Buffer)
    DriveExists = False
    For i = 1 To BuffLen
        If UCase(Mid(Buffer, i, 1)) = UCase(DLetter) Then
            DriveExists = True
            Exit Function
        End If
    Next i
End Function
Sub Main()
  Debug.Print DriveExists("c:\")
End Sub

The NumberOfBytesFree Function

 
Function NumberOfBytesFree(ByVal strDrive As String) As String
   Dim lngSectors As Long
   Dim lngBytes As Long
   Dim lngFreeClusters As Long
   Dim lngTotalClusters As Long
   Dim intErrNum As Integer
   intErrNum = abGetDiskFreeSpace(strDrive, lngSectors, _
   lngBytes, lngFreeClusters, lngTotalClusters)
   NumberOfBytesFree = " with " & _
         Format((CDbl(lngBytes) * CDbl(lngSectors)) * _
         CDbl(lngFreeClusters), "#,##0") & _
         " Bytes Free"
End Function

The TypeOfDrive Function

 
Function TypeOfDrive(ByVal strDrive As String) As String
   Dim intDriveType As Integer
   Dim strDriveType As String
      intDriveType = abGetDriveType(strDrive)
      Select Case intDriveType
         Case DRIVE_UNKNOWN
            strDriveType = "Type Unknown"
         Case DRIVE_UNAVAILABLE
             strDriveType = "Drive Doesn"t Exist"
         Case DRIVE_REMOVABLE
             strDriveType = "Removable Drive"
         Case DRIVE_FIXED
             strDriveType = "Fixed Drive"
         Case DRIVE_REMOTE
             strDriveType = "Network Drive"
         Case DRIVE_CDROM
             strDriveType = "CD-ROM"
         Case DRIVE_RAMDISK
             strDriveType = "RAM Disk"
      End Select
      TypeOfDrive = strDriveType
End Function