fortypoundhead.com

Get Available Drivespace with VB6

Posted On 2012-11-25 by dwirch
Keywords:
Tags: VB6 System Services VB6 Windows API VB6 Miscellaneous Windows
Views: 1393


As a developer, from time to time you are called upon to build or process large chunks of data. During this process, you can use the the local hard drive as a temporary holding area. Admittedly, with todays well-specc'd computers, you shouldn't need to do this, but back in the day, this was the norm.

By request, here is a set of API functions for use with Visual Basic 6 that will return various pieces of information about local storage, such as total space, free space, etc.

I've tried to take line wrap in to account, but watch out! I may have missed one.

Option Explicit

Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" _
    (ByVal lpLibFileName As String) As Long

Private Declare Function FreeLibrary Lib "kernel32" _
    (ByVal hLibModule As Long) As Long

Private Declare Function GetProcAddress Lib "kernel32" _
    (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
    (ByVal lpRootPathName As String, _
    lpSectorsPerCluster As Long, _
    lpBytesPerSector As Long, _
    lpNumberOfFreeClusters As Long, _
    lpTtoalNumberOfClusters As Long) As Long 'C Bool

Private Declare Function GetDiskFreeSpaceExAsCurrency Lib "kernel32" Alias "GetDiskFreeSpaceExA" _
    (ByVal lpDirectoryName As String, _
    lpFreeBytesAvailableToCaller As Currency, _
    lpTotalNumberOfBytes As Currency, _
    lpTotalNumberOfFreeBytes As Currency) As Long 'C Bool

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (lpvDest As Any, _
    lpvSource As Any, _
    ByVal cbCopy As Long)

Public Function vbGetAvailableBytesAsString(Optional ByVal sPath As String = "") As String
    
Dim lo As Long, hi As Long
    Dim sOut As String

    If ExistGetDiskFreeSpaceEx() Then
        sOut = vbGetAvailableBytesEx(sPath)
    Else
        sOut = CStr(vbGetAvailableBytes(sPath))
    End If
    vbGetAvailableBytesAsString = sOut

End Function

Public Function vbGetAvailableKBytesAsString(Optional ByVal sPath As String = "") As String
    
Dim bytes As Currency, kBytes As Currency
    Dim sTmp As String

    sTmp = vbGetAvailableBytesAsString(sPath)
    bytes = CCur(sTmp)
    If bytes Then 'avoid divide by 0 errors
        kBytes = bytes / 1024
        kBytes = Fix(kBytes)
    Else
        kBytes = 0
    End If
    
vbGetAvailableKBytesAsString = CStr(kBytes)

End Function

Public Function vbGetAvailableMBytesAsString(Optional ByVal sPath As String = "") As String
    
Dim kBytes As Currency, mBytes As Currency
    Dim sTmp As String

    sTmp = vbGetAvailableKBytesAsString(sPath)
    kBytes = CCur(sTmp)
    If kBytes Then 'avoid divide by 0 errors
        mBytes = kBytes / 1024
        mBytes = Fix(mBytes)
    Else
        mBytes = 0
    End If
    vbGetAvailableMBytesAsString = CStr(mBytes)

End Function

Public Function vbGetTotalBytesAsString(Optional ByVal sPath As String = "") As String
    
Dim lo As Long, hi As Long
    Dim sOut As String

    If ExistGetDiskFreeSpaceEx() Then
        sOut = vbGetTotalBytesEx(sPath)
    Else
        sOut = CStr(vbGetTotalBytes(sPath))
    End If
        vbGetTotalBytesAsString = sOut

End Function

Public Function vbGetTotalKBytesAsString(Optional ByVal sPath As String = "") As String
    
Dim numbytes As Currency, kBytes As Currency
    Dim sTmp As String

    sTmp = vbGetTotalBytesAsString(sPath)
    numbytes = CCur(sTmp)
    If numbytes Then 'avoid divide by 0 errors
        kBytes = numbytes / 1024
        kBytes = Fix(kBytes)
    Else
        kBytes = 0
    End If
    vbGetTotalKBytesAsString = CStr(kBytes)

End Function

Public Function vbGetTotalMBytesAsString(Optional ByVal sPath As String = "") As String

    Dim kBytes As Currency, mBytes As Currency
    Dim sTmp As String

    sTmp = vbGetTotalKBytesAsString(sPath)
    kBytes = CCur(sTmp)
    If kBytes Then 'avoid divide by 0 errors
        mBytes = kBytes / 1024
        mBytes = Fix(mBytes)
    Else
        mBytes = 0
    End If
    vbGetTotalMBytesAsString = CStr(mBytes)

End Function

Public Function ExistGetDiskFreeSpaceEx() As Boolean
    
Dim hInst As Long
    Dim procAddress As Long

    hInst = LoadLibrary("kernel32.dll")
    If hInst Then
        procAddress = GetProcAddress(hInst, "GetDiskFreeSpaceExA")
        Call FreeLibrary(hInst)
    End If
    ExistGetDiskFreeSpaceEx = CBool(procAddress)

End Function

Private Function vbGetAvailableBytesEx(ByVal sPath As String) As String

    Dim BytesAvailable As Currency
    Dim TotalBytes As Currency
    Dim TotalFreeBytes As Currency
    Dim tmp As Currency

    On Error GoTo APIfailed
    If "" = sPath Then
        Call GetDiskFreeSpaceExAsCurrency(vbNullString, BytesAvailable, TotalBytes, TotalFreeBytes)
    Else
        Call GetDiskFreeSpaceExAsCurrency(sPath, BytesAvailable, TotalBytes, TotalFreeBytes)
    End If

    'If BytesAvailable Then
        BytesAvailable = BytesAvailable * 10000
        vbGetAvailableBytesEx = CStr(BytesAvailable)
    'End If

    Exit Function

    APIfailed:
    'returns false
    Debug.Print "GetDiskFreeSpaceEx() API Failed!"

End Function

Private Function vbGetTotalBytesEx(ByVal sPath As String) As String
    
Dim BytesAvailable As Currency
    Dim TotalBytes As Currency
    Dim TotalFreeBytes As Currency

    On Error GoTo APIfailed
    If "" = sPath Then
        Call GetDiskFreeSpaceExAsCurrency(vbNullString, BytesAvailable, TotalBytes, TotalFreeBytes)
    Else
        Call GetDiskFreeSpaceExAsCurrency(sPath, BytesAvailable, TotalBytes, TotalFreeBytes)
    End If

    If TotalBytes Then
        TotalBytes = TotalBytes * 10000
    Else
        TotalBytes = 0
    End If
    vbGetTotalBytesEx = CStr(TotalBytes)

    Exit Function

    APIfailed:
    'returns false
    Debug.Print "GetDiskFreeSpaceEx() API Failed!"

End Function

Private Function vbGetAvailableBytes(ByVal sPath As String) As Long

    Dim lSpc As Long 'sectors per cluster
    Dim lBps As Long 'bytes per sector
    Dim lNfc As Long 'number of free clusters
    Dim lTnc As Long 'total number of clusters


    Call GetDiskFreeSpace(sPath, lSpc, lBps, lNfc, lTnc)
    vbGetAvailableBytes = lSpc * lBps * lNfc

End Function

Private Function vbGetTotalBytes(ByVal sPath As String) As Long

    Dim lSpc As Long 'sectors per cluster
    Dim lBps As Long 'bytes per sector
    Dim lNfc As Long 'number of free clusters
    Dim lTnc As Long 'total number of clusters

    Call GetDiskFreeSpace(sPath, lSpc, lBps, lNfc, lTnc)
    vbGetTotalBytes = lSpc * lBps * lTnc

End Function

Public Function vbGetPercentAvailable(Optional ByVal sPath As String = "") As Long

    Dim freeEX As Currency
    Dim totalEX As Currency
    Dim availEX As Currency
    Dim percent As Long

    On Error Resume Next 'if API fails there will be divide by zero errors

    If ExistGetDiskFreeSpaceEx() Then
        If "" = sPath Then
            Call GetDiskFreeSpaceExAsCurrency(vbNullString, availEX, totalEX, freeEX)
        Else
            Call GetDiskFreeSpaceExAsCurrency(sPath, availEX, totalEX, freeEX)
        End If
    Else
        totalEX = vbGetTotalBytes(sPath)
        availEX = vbGetAvailableBytes(sPath)

    End If

    totalEX = totalEX * 10000
    availEX = availEX * 10000
    percent = (availEX * 100) / totalEX

    vbGetPercentAvailable = percent

End Function


About the Author

dwirch has posted a total of 179 articles.

You can find more information from dwirch by visiting http://www.derekwirch.com.


Comments On This Post

No comments on this post yet!


Do you have a thought relating to this post? You can post your comment here. If you have an unrelated question, you can use the Q&A section to ask it.

Or you can drop a note to the administrators if you're not sure where you should post.


Your IP address is:54.161.91.76

Before you can post, you need to prove you are human. If you log in, this test goes away.




Recent Forum Posts

Advanced search added
dwirch posted on September 23, 2017 at about 13:44 in Site News

Job Spammer: Gaurav Mehta - AgreeYa Solutions
dwirch posted on September 22, 2017 at about 10:35 in Spammers

Job Spammer: Prutha Siri - Javelin Systems
dwirch posted on September 10, 2017 at about 6:15 in Spammers

New security implemented
dwirch posted on September 7, 2017 at about 7:16 in Site News

Malicious IP Checker Companion Tool
dwirch posted on August 12, 2017 at about 20:24 in Site News

Job Spammer: Steve Adams
dwirch posted on August 8, 2017 at about 7:44 in Spammers