article

Drive Info

Email
Submitted on: 3/8/2018 4:23:20 PM
By: Quake 
Level: Intermediate
User Rating: By 1 Users
Compatibility: VB 6.0
Views: 3273
 
     Grab Drive Information - Includes Demo

This article has accompanying files

 
				'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

winzip iconDownload article

Note: Due to the size or complexity of this submission, the author has submitted it as a .zip file to shorten your download time. Afterdownloading it, you will need a program like Winzip to decompress it.Virus note:All files are scanned once-a-day by Planet Source Code for viruses, but new viruses come out every day, so no prevention program can catch 100% of them. For your own safety, please:
  1. Re-scan downloaded files using your personal virus checker before using it.
  2. NEVER, EVER run compiled files (.exe's, .ocx's, .dll's etc.)--only run source code.
  3. Scan the source code with Minnow's Project Scanner

If you don't have a virus scanner, you can get one at many places on the net including:McAfee.com


Other 32 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this article (in the Intermediate category)?
(The article with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments

3/27/2018 5:26:33 PMQuake

Tagging my "EXAMPLE" code submission isn't going to do you any good to win anything. Keep tagging my "EXAMPLE" codes with negative votes all you want. I couldn't care less.

If you don't like it "DON'T Download IT"!
(If this comment was disrespectful, please report it.)

 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular article, please click here instead.)
 

To post feedback, first please login.