フォルダのサイズを取得したい

質問

WindowsXP+VB6.0を使用して、特定フォルダ内のサイズを取得したいのです。FileSystemObjectのFolderオブジェクトのSizeプロパティでは
特定フォルダのプロパティのサイズの値となってしまいます。
取得したいのは「ディスク上のサイズ」の値です。

宜しくお願い致します。

回答No.5

Starfish_goo

ちょっとサンプルを作ってみました。実際に使うには、いろんな環境で確認してから使ってください。

　使用方法は、getFolderSize("c:\temp")のようにパス名を指定して関数を呼んでください。結果は、２GB以上でもOKなようにCurrency型で返ります。

　尚、WindowsのAPIの定義は、APIビューワからコピーしてください。

' 指定したフォルダのディスク上のサイズを求める
Function getFolderSize(strFolderName As String) As Currency
Dim udtVersionInfo As OSVERSIONINFO ' OSのバージョン取得用
Dim fso As FileSystemObject ' FileSystemObject のハンドル
Dim fldr As Folder '　フォルダオブジェクトのハンドル
Dim sfldr As Folder ' サブフォルダのオブジェクトのハンドル
Dim fil As File ' ファイルオブジェクトのハンドル
Dim curSum As Currency ' ファイルサイズの合計
Dim lngFileSizeHigh As Long ' ファイルサイズの上位 DWORD
Dim lngFileSizeLow As Long ' ファイルサイズの下位 DWORD
Dim lngReturnValue As Long ' 戻り値
Dim lngSectorsPerCluster As Long ' セクタ数／クラスタ
Dim lngBytesPerSector As Long ' バイト数／セクタ
Dim lngNumberOfFreeClusters As Long ' 空きクラスタ数
Dim lngTotalNumberOfClusters As Long ' 全クラスタ数
Dim lngClusterSize As Long ' クラスタサイズ

' 合計をクリア
curSum = 0

' OSのプラットフォームを調べる
udtVersionInfo.dwOSVersionInfoSize = Len(udtVersionInfo)
lngReturnValue = GetVersionEx(udtVersionInfo)

' ドライブのクラスタサイズを調べる
lngReturnValue = GetDiskFreeSpace(Left(strFolderName, 3), lngSectorsPerCluster, lngBytesPerSector, lngNumberOfFreeClusters, lngTotalNumberOfClusters)
lngClusterSize = lngSectorsPerCluster * lngBytesPerSector

' FileSystemObject オブジェクトの作成
Set fso = New FileSystemObject
' フォルダオブジェクトのハンドルを取得
Set fldr = fso.GetFolder(strFolderName)

' サブフォルダを列挙し、再帰的に呼び出す
For Each sfldr In fldr.SubFolders
curSum = curSum + getFolderSize(sfldr.Path)
Next sfldr

' ファイルを列挙し、ディスク上のファイルサイズを求める
For Each fil In fldr.Files
If udtVersionInfo.dwPlatformId = "1" Then ' 95系OS
curSum = curSum + RoundUp(fil.Size, lngClusterSize)
Else
If Right(strFolderName, 1) = "\" Then
lngFileSizeLow = GetCompressedFileSize(strFolderName & fil.Name, lngFileSizeHigh)
Else
lngFileSizeLow = GetCompressedFileSize(strFolderName & "\" & fil.Name, lngFileSizeHigh)
End If
curSum = curSum + RoundUp(MergeDWORD(lngFileSizeHigh, lngFileSizeLow), lngClusterSize)
List1.AddItem CStr(RoundUp(MergeDWORD(lngFileSizeHigh, lngFileSizeLow), lngClusterSize)) & " " & strFolderName & "\" & fil.Name
End If
Next fil

' オブジェクトの解放
Set fil = Nothing
Set sfldr = Nothing
Set fldr = Nothing
Set fso = Nothing

' 合計を戻り値にセット
getFolderSize = curSum

End Function

' 2つのDWORDに分割された値をCurrency型に変換
Function MergeDWORD(lngFileSizeHigh As Long, lngFileSizeLow As Long) As Currency

If (lngFileSizeLow And &H80000000) = &H80000000 Then
MergeDWORD = CCur(lngFileSizeHigh) * 4294967296@ _
+ 2147483648@ + CCur(lngFileSizeLow)
Else
MergeDWORD = CCur(lngFileSizeHigh) * 4294967296@ _
+ CCur(lngFileSizeLow)
End If

End Function

' クラスタサイズの倍数に切り上げる
Function RoundUp(curFileSize As Currency, lngClusterSize As Long) As Currency
Dim curMod As Currency ' 余り

curMod = curFileSize Mod lngClusterSize
If curMod <> 0 Then
RoundUp = curFileSize + (lngClusterSize - curMod)
Else
RoundUp = curFileSize
End If

End Function

GetDiskFreeSpace関数について
・Windows 95（OSR2以前）では、正しい値を返しません。
・将来的に使えなくなる場合があります。（Vistaは、OK）
詳しくは、下記を参照
http://msdn.microsoft.com/ja-jp/library/cc429305.aspx

GetCompressedFileSize関数について
・ファイルを圧縮している場合は、GetCompressedFileSize関数を使う必要があります。
・ファイルサイズがクラスタサイズより小さいと、もとのファイルサイズのままなのでクラスタサイズに切り上げる処理を入れてます。
・95系のOSではサポートしていないので、バージョンのチェックを入れています。