Drive Info

by Quake (33 Submissions)
Category: Files/File Controls/Input/Output
Compatability: VB 6.0
Difficulty: Intermediate
Date Added: Fri 12^th February 2021
Rating: (0 Votes)
Grab Drive Information
Rate Drive Info
'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
Download this snippet Add to My Saved Code
Drive Info Comments

No comments have been posted about Drive Info. Why not be the first to post a comment about Drive Info.
Drive Info

Drive Info Comments

Post your comment

Difficulty
