White Tiger

Microsoft Excel VBA - ディスクの容量や空き容量を取得する方法

◆概要

このページは、Excel VBAやVisual Basic 6.0でディスクの容量や空き容量を取得する方法について記載しています。

◆APIのGetDiskFreeSpaceを使う方法

APIのGetDiskFreeSpaceを使うと、ディスクの容量や空き容量を取得することができます。
Windows 95 と Windows 98 のすべてのバージョンでは、GetDiskFreeSpace は 2 GB の最大合計サイズと最大空き容量サイズを返します。逆に言えば、ディスクのサイズが2GB以上は正しい数値を返してきません。この制限は、Windows 95 の最初のバージョンが最大 2 GB の容量しかサポートしていないためのものです。

◆Sample code

Option Explicit

'API宣言
'（２ギガまで）
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
 
Public Function DiskFreeMB(ByVal MODE As String, ByVal RootPath As String) _
                                                                As Double
  Dim rc As Long
  Dim lpRootPathName As String          'ルートのパス　”C:\"など
  Dim lpSectorsPerCluster As Long       'クラスタ当たりのセクタ数
  Dim lpBytesPerSector As Long          'セクタ当たりのバイト数
  Dim lpNumberOfFreeClusters As Long    'クラスタの空き数
  Dim lpTtoalNumberOfClusters As Long   'クラスタの総数
  
  
  'ルートディレクトリを指定
  lpRootPathName = RootPath
  
  '関数の実行
  rc = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, _
                lpBytesPerSector, lpNumberOfFreeClusters, _
                lpTtoalNumberOfClusters)
  Select Case MODE
  Case "空き容量"
    DiskFreeMB = CDbl(lpSectorsPerCluster) * CDbl(lpBytesPerSector) * _
                CDbl(lpNumberOfFreeClusters) / CDbl(1048576)
  Case "ディスク容量"
    DiskFreeMB = CDbl(lpSectorsPerCluster) * CDbl(lpBytesPerSector) * _
                CDbl(lpTtoalNumberOfClusters) / CDbl(1048576)
  End Select
  

End Function

Sub GetFreeSpace()
'ディスクの空き容量を取得する

    Dim dbFreespace As Double
    dbFreespace = DiskFreeMB("空き容量", "C:\")
    MsgBox dbFreespace
    
End Sub

Sub GetTotalDisk()
'ディスクの総容量を取得する

    Dim dbTotalspase As Double
    dbTotalspase = DiskFreeMB("ディスク容量", "C:\")
    MsgBox dbTotalspase
End Sub

◆GetDiskFreeSpaceEx 関数を使う方法

Windows 95 OSR 2（OEM Service Release 2）以降では、GetDiskFreeSpaceEx 関数が利用できます。GetDiskFreeSpaceEx 関数は、ボリュームが 2GB より大きいときも、正しい値を返します。

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

' ドライブの空き容量を得る。
Private Function DiskFreeSpace(ByVal MODE As String, _
                        strDriveRoot As String) As Currency
    ' strDriveRoot : ドライブのルート(例: "C:\")
    Dim lngResult                As Long
    Dim curFreeAvailableToCaller As Currency
    Dim curTotalByte             As Currency
    Dim curTotalFreeByte         As Currency

    lngResult = GetDiskFreeSpaceEx(strDriveRoot, _
                                   curFreeAvailableToCaller, _
                                   curTotalByte, _
                                   curTotalFreeByte)
    Select Case MODE
        Case "空き容量"
            ' 通貨型で受けて、10000倍するとVBで正しい数値となる。
            DiskFreeSpace = curTotalFreeByte * 10000@
        Case "ディスク容量"
            ' 全容量なら curTotalByte * 10000@ で得られる。
            DiskFreeSpace = curTotalByte * 10000@
    End Select
    
End Function

Sub GetFreeSpace()
'ディスクの空き容量を取得する

    Dim dbFreespace As Double
    dbFreespace = DiskFreeSpace("空き容量", "C:\")
    MsgBox "空き容量は " & dbFreespace & " Byteです。", _
                            vbOKOnly + vbInformation
    
End Sub

Sub GetTotalDisk()
'ディスクの総容量を取得する

    Dim dbTotalspase As Double
    dbTotalspase = DiskFreeSpace("ディスク容量", "C:\")
    MsgBox "ディスク容量は " & dbTotalspase & " Byteです。", _
                            vbOKOnly + vbInformation
    
End Sub

◆SHGetDiskFreeSpaceを使う方法

Internet Explorer 4.0以上がインストールされた環境でなら、 SHGetDiskFreeSpace が使えます。

Private Declare Function SHGetDiskFreeSpace Lib "shell32" Alias _
                                "SHGetDiskFreeSpaceA" _
                                (ByVal pszVolume As String, _
                                 pqwFreeCaller As Currency, _
                                 pqwTot As Currency, _
                                 pqwFree As Currency) As Long
                                 
Private Sub Command1_Click()
    Dim lngResult       As Long
    Dim curFreeCaller   As Currency
    Dim curTot          As Currency
    Dim curFree         As Currency

    lngResult = SHGetDiskFreeSpace("C:\", _
                                   curFreeCaller, _
                                   curTot, _
                                   curFree)
    ' 成功。
    If (lngResult <> 0) Then
        MsgBox "ユーザーが利用できるディスクの空き容量 : " & _
                Format$(curFreeCaller * 10000, "#,##0") & "Bytes" & vbCr & _
                "ディスクの総容量 : " & Format$(curTot * 10000, "#,##0") & _
                "Bytes" & vbCr & _
                "ディスクの空き容量 : " & Format$(curFree * 10000, "#,##0") & _
                "Bytes"
    End If
End Sub

Link