Source code for Issue Number 50

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. Source code may not be reproduced except for use in a compiled executable. All rights reserved. If you would like to reprint any or all of this code please email us at info@codeoftheweek.com

Code of the Week Home


Source Code

Just paste this source code into a class module called cVolumeInfo and include it in your project.

'----------------------------------------------------------------------
'
'   Module Name:     cVolumeInfo
'   Written By:     C&D Programming Corp.
'   Create Date:    7/98
'   Copyright:      Copyright 1998 by C&D Programming Corp.  Source
'                   code may not be reproduced except for use in a
'                   compiled executable.  All rights reserved.  If
'                   you would like to reprint any or all of this
'                   code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit

'
'   This API call allows us to gather volume information
'
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

'
'   This API call allows us determine what type of
'   we are looking at.
'
Private Declare Function GetDriveType Lib "KERNEL32" _
                        Alias "GetDriveTypeA" _
                        (ByVal nDrive As String) As Long
'
'   Return values from the GetDriveType API call
'
Private Const DRIVE_UNKNOWN = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6

Dim msDrive As String
Dim msLabel As String

Public Property Get Drive() As String
    Drive = msDrive
End Property

Public Property Let Drive(sDrive As String)

    On Error Goto Handler

    If Left(sDrive, 2) = "\\" Then
        Err.Raise 5, "cVolumeInfo.Drive", "Network drives are not supported in this version."
        Exit Property
    Else
        msDrive = Left(sDrive, 1) & ":\"
    End If
    GetVolumeLabel
    Exit Property

Handler:
    Err.Raise Err.Number, Err.Source, Err.Description
End Property

Public Property Get Label() As String
    Label = msLabel
End Property

Private Sub GetVolumeLabel()
    Dim lRet As Long
    Dim sLabel As String
    Dim lLabelSize As Long
    Dim lSerialNumber As Long
    Dim lMaxComponentLen As Long
    Dim lFileSysFlags As Long
    Dim sFileSysName As String
    Dim lFileSysNameSize As Long
    Dim lDriveType As Long

    lDriveType = GetDriveType(Drive)

    '
    ' don't include unknown drives and network drives
    '
    If lDriveType <> DRIVE_UNKNOWN And lDriveType <> DRIVE_REMOTE Then
        sLabel = String$(64, 0)
        lLabelSize = 63
        lRet = GetVolumeInformation(Drive, sLabel, lLabelSize, lSerialNumber, _
                    lMaxComponentLen, lFileSysFlags, sFileSysName, lFileSysNameSize)
        Select Case Err.LastDllError
            Case 21
                msLabel = ""  ' device is not ready
            Case 111
                ' buffer for label not large enough.
            Case 0 ' success
                msLabel = Left(sLabel, lLabelSize)
            Case Else
                msLabel = ""
                Err.Raise Err.LastDllError, "cVolumeInfo.GetVolumeLabel", "API Error " & Err.LastDllError
        End Select
    Else
        msLabel = ""
    End If
End Sub