Account Login Username:
Active Server Pages Coding Standards Complete Applications Custom Controls/Forms/Menus Data Structures Databases/Data Access/DAO/ADO DDE Debugging and Error Handling DirectX Encryption Files/File Controls/Input/Output Games Graphics Internet/HTML Jokes/Humor Libraries Math/Dates Microsoft Office Apps/VBA Miscellaneous Object Oriented Programming (OOP) OLE/COM/DCOM/Active-X Registry Sound/MP3 String Manipulation VB function enhancement Windows API Call/Explanation Windows CE Windows System Services
by Quake (33 Submissions) Category: Files/File Controls/Input/OutputCompatability: VB 6.0Difficulty: Intermediate Date Added: Fri 12th February 2021 Rating: (0 Votes)
Grab Drive Information
'ModuleOption ExplicitPublic 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 drivePrivate 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 LongPrivate 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 LongPrivate Declare Function GetLogicalDrives Lib "kernel32" () As LongPrivate Declare Function WNetGetConnection Lib "mpr.dll" _Alias "WNetGetConnectionA" _(ByVal lpszLocalName As String, _ByVal lpszRemoteName As String, _cbRemoteName As Long) As LongPrivate Type LARGE_INTEGERlowpart As Longhighpart As LongEnd TypePrivate Declare Function GetDiskFreeSpaceEx Lib "kernel32" _Alias "GetDiskFreeSpaceExA" _(ByVal lpRootPathName As String, _lpFreeBytesAvailableToCaller As LARGE_INTEGER, _lpTotalNumberOfBytes As LARGE_INTEGER, _lpTotalNumberOfFreeBytes As LARGE_INTEGER) As LongPrivate Declare Function SHGetDiskFreeSpace Lib "shell32" _Alias "SHGetDiskFreeSpaceA" _(ByVal pszVolume As String, _pqwFreeCaller As Currency, _pqwTot As Currency, _pqwFree As Currency) As LongPrivate Const MAX_PATH = 256Public Function GetDiskSize(sDrive As String) As StringDim lRet As LongDim liAvailable As LARGE_INTEGERDim liTotal As LARGE_INTEGERDim liFree As LARGE_INTEGERDim dblUsed As DoubleDim dblTotal As DoubleDim dblFree As DoubleIf Len(sDrive) = 1 ThensDrive = sDrive & ":\"ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" ThensDrive = sDrive & "\"End If'Determine the Available Space, Total Size and Free Space of a drivelRet = 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 resultsGetDiskSize = "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 FunctionPrivate Function CLargeInt(Lo As Long, Hi As Long) As Double'This function converts the LARGE_INTEGER data type to a doubleDim dblLo As Double, dblHi As DoubleIf Lo < 0 ThendblLo = 2 ^ 32 + LoElsedblLo = LoEnd IfIf Hi < 0 ThendblHi = 2 ^ 32 + HiElsedblHi = HiEnd IfCLargeInt = dblLo + dblHi * 2 ^ 32End FunctionPublic Sub AutosizeColumns(ByVal TargetListView As ListView)On Error GoTo Err_ProcDim lngColumn As LongConst SET_COLUMN_WIDTHAs Long = 4126Const AUTOSIZE_USEHEADER As Long = -2For lngColumn = 0 To (TargetListView.ColumnHeaders.Count - 1)Call SendMessage(TargetListView.hWnd, _ SET_COLUMN_WIDTH, _ lngColumn, _ ByVal AUTOSIZE_USEHEADER)Next lngColumnExit SubErr_Proc:Call Error("AutosizeColumns")End SubPublic Function FormatSize(ByVal Size As Currency) As StringConst Kilobyte As Currency = [email protected]Const HundredK As Currency = [email protected]Const ThousandK As Currency = [email protected]Const Megabyte As Currency = [email protected]Const HundredMeg As Currency = [email protected]Const ThousandMeg As Currency = [email protected]Const Gigabyte As Currency = [email protected]Const Terabyte As Currency = [email protected]If Size < Kilobyte ThenFormatSize = Int(Size) & " bytes"ElseIf Size < HundredK ThenFormatSize = Format(Size / Kilobyte, "#.0") & " KB"ElseIf Size < ThousandK ThenFormatSize = Int(Size / Kilobyte) & " KB"ElseIf Size < HundredMeg ThenFormatSize = Format(Size / Megabyte, "#.0") & " MB"ElseIf Size < ThousandMeg ThenFormatSize = Int(Size / Megabyte) & " MB"ElseIf Size < Terabyte ThenFormatSize = Format(Size / Gigabyte, "#.00") & " GB"ElseFormatSize = Format(Size / Terabyte, "#.00") & " TB"End IfEnd FunctionPublic Function GetDiskSerialNumber(sDrive As String) As LongDim lRet As Long'Deal with one and two character input valuesIf Len(sDrive) = 1 ThensDrive = sDrive & ":\"ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" ThensDrive = sDrive & "\"End IflRet = GetVolumeInformation(sDrive, vbNullString, 0, GetDiskSerialNumber, ByVal 0&, ByVal 0&, vbNullString, 0)End FunctionPublic Function GetDriveName(ByVal sDrive As String) As StringDim sVolBuf As String, sSysName As StringDim lSerialNum As Long, lSysFlags As Long, lComponentLength As LongDim lRet As LongIf Len(sDrive) = 1 ThensDrive = sDrive & ":\"ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" ThensDrive = sDrive & "\"End IfsVolBuf = String$(256, 0)sSysName = String$(256, 0)lRet = GetVolumeInformation(sDrive, sVolBuf, MAX_PATH, lSerialNum, lComponentLength, lSysFlags, sSysName, MAX_PATH)If lRet > 0 ThensVolBuf = StripTerminator(sVolBuf)GetDriveName = StrConv(sVolBuf, vbProperCase)End IfEnd FunctionPublic Function GetDriveStrings() As StringDim result As Long ' Result of our API callsDim strDrives As String ' String to pass to API callDim lenStrDrives As Long' Length of the above stringresult = GetLogicalDriveStrings(0, strDrives)strDrives = String(result, 0)lenStrDrives = resultresult = GetLogicalDriveStrings(lenStrDrives, strDrives)If result = 0 ThenGetDriveStrings = ""ElseGetDriveStrings = strDrivesEnd IfEnd FunctionPublic Function GetFileSys(sDrive As String) As StringDim DvFileSys As String * 256Dim lRet As Long'Deal with one and two character input valuesIf Len(sDrive) = 1 ThensDrive = sDrive & ":\"ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" ThensDrive = sDrive & "\"End IflRet = GetVolumeInformation(sDrive, vbNullString, 0, ByVal 0&, ByVal 0&, ByVal 0&, DvFileSys, ByVal Len(DvFileSys))GetFileSys = DvFileSysEnd FunctionPublic Function GetName(sFileName As String) As StringDim k As IntegerGetName = sFileNamek = InStrRev(sFileName, "\")If k > 0 Then GetName = Right$(sFileName, Len(sFileName) - k)End FunctionPublic Function GetNetDriveName(ByVal sDrive As String) As StringDim sRemoteName As StringDim lRet As LongsDrive = Left$(sDrive, 2) '& Chr$(0)sRemoteName = Space$(255)lRet = WNetGetConnection(sDrive, sRemoteName, Len(sRemoteName))GetNetDriveName = StrConv(GetName(StripTerminator(sRemoteName)), vbProperCase)End FunctionPublic Sub Get_Drives(LSV As ListView)Dim strDrives As StringDim lvItem As ListItemDim pos As LongDim Drive As StringDim drivetype As LongLSV.ListItems.ClearstrDrives = GetDriveStrings()If strDrives = "" ThenMsgBox "No Drives were found!", vbCriticalElsepos = 1Do While Not Mid$(strDrives, pos, 1) = Chr(0)Drive = Mid$(strDrives, pos, 3)pos = pos + 4drivetype = GetDriveType(Drive)Select Case drivetypeCase 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 WithCase 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 WithCase 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 WithCase 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 WithEnd SelectCase 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 WithCase 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 WithCase 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 WithCase 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 WithCase 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 WithEnd SelectLoopEnd IfCall AutosizeColumns(LSV)End SubPrivate Function StripTerminator(ByVal strString As String) As StringDim intZeroPos As LongintZeroPos = InStr(strString, Chr$(0))If intZeroPos > 0 ThenStripTerminator = Left$(strString, intZeroPos - 1)ElseStripTerminator = strStringEnd IfEnd Function
Download this snippet Add to My Saved Code
No comments have been posted about Drive Info. Why not be the first to post a comment about Drive Info.
0/1000 characters