'Module Option Explicit Public Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" _ (ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long 'Determines whether a disk drive is a removable, fixed, CD-ROM, RAM disk, or network drive Private Declare Function GetDriveType Lib "kernel32" _ Alias "GetDriveTypeA" _ (ByVal nDrive As String) As Long 'Fills a buffer with strings that specify valid drives in the system. 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 GetLogicalDrives Lib "kernel32" () As Long Private Declare Function WNetGetConnection Lib "mpr.dll" _ Alias "WNetGetConnectionA" _ (ByVal lpszLocalName As String, _ ByVal lpszRemoteName As String, _ cbRemoteName As Long) As Long Private Type LARGE_INTEGER lowpart As Long highpart As Long End Type 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 SHGetDiskFreeSpace Lib "shell32" _ Alias "SHGetDiskFreeSpaceA" _ (ByVal pszVolume As String, _ pqwFreeCaller As Currency, _ pqwTot As Currency, _ pqwFree As Currency) As Long Private Const MAX_PATH = 256 Public Function GetDiskSize(sDrive As String) As String Dim lRet As Long Dim liAvailable As LARGE_INTEGER Dim liTotal As LARGE_INTEGER Dim liFree As LARGE_INTEGER Dim dblUsed As Double Dim dblTotal As Double Dim dblFree As Double If Len(sDrive) = 1 Then sDrive = sDrive & ":\" ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then sDrive = sDrive & "\" End If 'Determine the Available Space, Total Size and Free Space of a drive lRet = GetDiskFreeSpaceEx(sDrive, liAvailable, liTotal, liFree) 'Convert the return values from LARGE_INTEGER to doubles 'Returns the same as Free Space. [NO GOOD] 'dblUsed = CLargeInt(liAvailable.lowpart, liAvailable.highpart) dblFree = CLargeInt(liFree.lowpart, liFree.highpart) dblTotal = CLargeInt(liTotal.lowpart, liTotal.highpart) dblUsed = dblTotal - dblFree 'Display the results GetDiskSize = "Capacity:" & vbTab & Format$(dblTotal, "###,###,###,##0") & " bytes" & vbTab & FormatSize(dblTotal) & vbCrLf & _ "Used Space:" & vbTab & Format$(dblUsed, "###,###,###,##0") & " bytes" & vbTab & FormatSize(dblUsed) & vbCrLf & _ String(Len("Used Space:"), Chr(95)) & vbTab & String(Len(Format$(dblUsed, "###,###,###,##0") & " bytes"), Chr(95)) & vbTab & String(Len(FormatSize(dblUsed)), Chr(95)) & vbCrLf & vbCrLf & _ "Free Space:" & vbTab & Format$(dblFree, "###,###,###,##0") & " bytes" & vbTab & FormatSize(dblFree) End Function Private Function CLargeInt(Lo As Long, Hi As Long) As Double 'This function converts the LARGE_INTEGER data type to a double Dim dblLo As Double, dblHi As Double If Lo < 0 Then dblLo = 2 ^ 32 + Lo Else dblLo = Lo End If If Hi < 0 Then dblHi = 2 ^ 32 + Hi Else dblHi = Hi End If CLargeInt = dblLo + dblHi * 2 ^ 32 End Function Public Sub AutosizeColumns(ByVal TargetListView As ListView) On Error GoTo Err_Proc Dim lngColumn As Long Const SET_COLUMN_WIDTHAs Long = 4126 Const AUTOSIZE_USEHEADER As Long = -2 For lngColumn = 0 To (TargetListView.ColumnHeaders.Count - 1) Call SendMessage(TargetListView.hWnd, _ SET_COLUMN_WIDTH, _ lngColumn, _ ByVal AUTOSIZE_USEHEADER) Next lngColumn Exit Sub Err_Proc: Call Error("AutosizeColumns") End Sub 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 Function GetDiskSerialNumber(sDrive As String) As Long Dim lRet As Long 'Deal with one and two character input values If Len(sDrive) = 1 Then sDrive = sDrive & ":\" ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then sDrive = sDrive & "\" End If lRet = GetVolumeInformation(sDrive, vbNullString, 0, GetDiskSerialNumber, ByVal 0&, ByVal 0&, vbNullString, 0) End Function Public Function GetDriveName(ByVal sDrive As String) As String Dim sVolBuf As String, sSysName As String Dim lSerialNum As Long, lSysFlags As Long, lComponentLength As Long Dim lRet As Long If Len(sDrive) = 1 Then sDrive = sDrive & ":\" ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then sDrive = sDrive & "\" End If sVolBuf = String$(256, 0) sSysName = String$(256, 0) lRet = GetVolumeInformation(sDrive, sVolBuf, MAX_PATH, lSerialNum, lComponentLength, lSysFlags, sSysName, MAX_PATH) If lRet > 0 Then sVolBuf = StripTerminator(sVolBuf) GetDriveName = StrConv(sVolBuf, vbProperCase) End If End Function Public Function GetDriveStrings() As String Dim result As Long ' Result of our API calls Dim strDrives As String ' String to pass to API call Dim lenStrDrives As Long' Length of the above string result = GetLogicalDriveStrings(0, strDrives) strDrives = String(result, 0) lenStrDrives = result result = GetLogicalDriveStrings(lenStrDrives, strDrives) If result = 0 Then GetDriveStrings = "" Else GetDriveStrings = strDrives End If End Function Public Function GetFileSys(sDrive As String) As String Dim DvFileSys As String * 256 Dim lRet As Long 'Deal with one and two character input values If Len(sDrive) = 1 Then sDrive = sDrive & ":\" ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then sDrive = sDrive & "\" End If lRet = GetVolumeInformation(sDrive, vbNullString, 0, ByVal 0&, ByVal 0&, ByVal 0&, DvFileSys, ByVal Len(DvFileSys)) GetFileSys = DvFileSys End Function Public Function GetName(sFileName As String) As String Dim k As Integer GetName = sFileName k = InStrRev(sFileName, "\") If k > 0 Then GetName = Right$(sFileName, Len(sFileName) - k) End Function Public Function GetNetDriveName(ByVal sDrive As String) As String Dim sRemoteName As String Dim lRet As Long sDrive = Left$(sDrive, 2) '& Chr$(0) sRemoteName = Space$(255) lRet = WNetGetConnection(sDrive, sRemoteName, Len(sRemoteName)) GetNetDriveName = StrConv(GetName(StripTerminator(sRemoteName)), vbProperCase) End Function Public Sub Get_Drives(LSV As ListView) Dim strDrives As String Dim lvItem As ListItem Dim pos As Long Dim Drive As String Dim drivetype As Long LSV.ListItems.Clear strDrives = GetDriveStrings() If strDrives = "" Then MsgBox "No Drives were found!", vbCritical Else pos = 1 Do While Not Mid$(strDrives, pos, 1) = Chr(0) Drive = Mid$(strDrives, pos, 3) pos = pos + 4 drivetype = GetDriveType(Drive) Select Case drivetype Case 0: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "UNKNOWN" .Icon = "UNKNOWN" .Tag = 7 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "UNKNOWN" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With Case 1: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "UNKNOWN" .Icon = "UNKNOWN" .Tag = 7 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "UNMOUNTED" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With Case 2: Select Case LCase(Left$(Drive, 1)) Case "a", "b": Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "FLOPPY" .Icon = "FLOPPY" .Tag = 1 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "Floppy Drive" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With Case Else: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "USBD" .Icon = "USBD" .Tag = 4 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "Removable Media" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With End Select Case 3: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "HDD" .Icon = "HDD" .Tag = 2 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "Fixed Drive" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) .SubItems(5) = GetDiskSize(Drive) End With Case 4: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "NETD" .Icon = "NETD" .Tag = 6 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "Remote (Network) Drive" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With Case 5: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "CD" .Icon = "CD" .Tag = 3 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "CD-ROM drive" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With Case 6: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "USBD" .Icon = "USBD" .Tag = 6 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "RAM disk" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With Case Else: Set lvItem = LSV.ListItems.Add() With lvItem .SmallIcon = "UNKNOWN" .Icon = "UNKNOWN" .Tag = 8 .Text = Drive .SubItems(1) = GetDriveName(Drive) .SubItems(2) = "UNKNOWN" .SubItems(3) = Trim(Hex$(GetDiskSerialNumber(Drive))) .SubItems(4) = GetFileSys(Drive) End With End Select Loop End If Call AutosizeColumns(LSV) End Sub Private Function StripTerminator(ByVal strString As String) As String Dim intZeroPos As Long intZeroPos = InStr(strString, Chr$(0)) If intZeroPos > 0 Then StripTerminator = Left$(strString, intZeroPos - 1) Else StripTerminator = strString End If End Function