指定フォルダ内の Officeファイル のページ数を取得します。
結果はデスクトップに「ファイルリスト_yymmdd_hhmm.xlsx」という名前で出力されます。こんな感じです。
A1セル：指定したフォルダ
B列：階層
C列：サブフォルダ
D列：ファイル名（ページ数取得対象外のファイルも含め全てのファイル）
E列：ページ数
ページ数を取得できるファイルは次の通りです
・Excel : xls ,xlsx ,xlsm, xlsb
・Word : doc ,docx ,docm
・PowerPoint :ppt ,pptx ,pptm
F列：構成情報（見出し）
G列：ファイルサイズ(MB)
はじめにこちらの過剰書きをお読みいただくようお願いします。（長くてすみません）
- ソース34行目にある通り、Excelで参照設定が必要なライブラリがあります。環境によって少し名前が異なりますが似た名前のがあるはずなので、探して設定をお願いします。
- htmlにおいてソース上に「&」や「"」が混入してしまうことがあるため、本ページ上のソースをコピペせず、「ソースのダウンロード（txt）」ボタンをご利用ください。（私の利用する環境のバグに起因しており、解消方法をさぐっていますが、現状は根本対処ができておりません）
- バージョン 2203 からマイクロソフトのマクロ実行に関する制限が厳しくなりました。
a) マクロの実行時
b) Excel VBAからWordやPowerPointのオブジェクト操作時
の2つのタイミングで実行がブロックされます。
a)は他のマクロでも同様の話であり、インターネットにかなり情報があるのでそちらを参照ください。
b)については、Excelの[ファイル]-[その他]-[オプション]で、[トラストセンター]-[トラストセンターの設定]から[マクロの設定]画面で「VBAプロジェクトオブジェクトモデルへのアクセスを信頼する」にチェックをすることでエラーが回避できます。（ただしマイクロソフトの推奨するデフォルトのセキュリティレベルを下げることになりますので、その点ご理解の上実施ください） - 本処理では、ページ数を出すところまでですが、フォルダごとに集計する方法についてもこのページの下部に書いてあります。
- 動作確認の上ご利用ください。Officeファイルは状態が多く、すべての場合にきちんと動くかの検証が難しいためです。私が利用する範囲でうまく動くことを確認しています。
- 本ページは企業からのアクセスが多いですが、本コンテンツを利用したことにより生ずるいかなる損害についても一切の責任を負いかねますので、自己責任でご利用ください。
- バグを発見した場合はフィードバックからご連絡ください。再現可能な範囲で善処します。
どこかの誰かがページ数を数えるという単純作業から解放されますように。Good luck!
ソース
Option Explicit
Option Base 1
Dim FilePaths() 'ファイルパス
Sub フォルダ内のファイルのページ数を取得する()
'------------------------------------------------------------------------------
'フォルダ内のファイルのページ数を取得
' [対応形式] Excel, Word, PowerPoint の拡張子の一部
'
' [補足1] PDFはバージョン違いによる差異の考慮が多い点と、
' 最新では処理が冗長になってしまう点を踏まえ非対応
' [補足2] Excel2007/2010は下記バグ情報あり(詳細未確認)
' Excel 2007 および Excel 2010 で Pages.Count プロパティを取得すると実際の印刷総ページ数と異なる値を取得する
' https://support.microsoft.com/ja-jp/help/2439589
'
' [版数 変更履歴]
' 1.10 拡張子「xlsb」を追加
' Excelのクローズ処理を修正
' Excelで非表示シートが表示できない場合の処理を追加
' 項目の出力を一部変更（出力順変更、ページ数/フォルダを廃止）
' 結果を出力するExcelファイルにウィンドウ枠の固定、画面スクロール処理を追加
' 結果出力後、並び替え処理を追加（サブフォルダの並びが直観的でないため並び替え）
' 1.20 Word ApplicationのQuitが漏れていたため追加
' 画面スクロールの修正
' サブフォルダ出力の判定を修正（仮想環境でフォルダ名が大文字だったり小文字だったりする対応）
' 1.30 PowerPointにスライド0がある場合の処理を追加
' 1.40 階層数の誤りを修正
' Wordの保護文書は見出しを無視するように修正
' その他軽微な修正
'------------------------------------------------------------------------------
'参照設定が必要なライブラリ（[ツール]-[参照設定]で設定しておく）
'Microsoft ActiveX Data Objects 6.1 Library
'Microsoft PowerPoint xx.x Object Library
'Microsoft Word xx.x Object Library
Dim StartTime As Date '開始時刻
StartTime = Now() '開始時刻
Dim EndTime As Date '終了時刻
Dim MsgRtn As String 'メッセージボックスの返り値
Dim WSH As Variant 'WSH(Windows Scripting Host)
Dim FSO As Object 'ファイルシステムオブジェクト
Dim DefaultPath As String 'ファイルダイアログのデフォルト表示パス
Dim strFolderPath As String 'ダイアログで指定されたフォルダパス
Dim objFolder As Object 'フォルダオブジェクト
Dim lngFileCount As Long '処理するファイル数
Dim intDepth As Integer '階層数
Dim i As Long
Dim p As Long 'スライドカウント用変数
Dim xlsworkbook As Workbook '開いたExcelファイル
Dim sh As Variant 'シート(worksheet,chart)
Dim shVisible As String 'シートの表示状態
Dim ErrShVisible As Boolean 'シート表示エラー
Dim strHiddenSheet As String '非表示シートの場合に結果に表示する文字列
Dim lngShPageCount As Long 'シートのページ数
Dim lngPageCount As Long 'ファイル内のページ数
Dim wordApp As Word.Application 'Word
Dim wordDoc As Word.document 'Wordファイル
Dim pptApp As PowerPoint.Application 'PowerPoint
Dim pptPrs As PowerPoint.Presentation 'PowerPointファイル
Dim lngFirstSlideNo As Long
Dim xlsWorkbookOutput As Workbook '結果を出力するExcelファイル
Const strBaseName As String = "ファイルリスト" '結果を出力するファイル名の固定文字列部
Const strExtName As String = "xlsx" '結果を出力するファイル名の拡張子
Dim strDate As String '結果を出力するファイル名の日時部
Dim strOutputFileName As String '結果を出力するファイル名
Const intColHeadColer As Long = 12566463 '表見出しの色（グレー「白、背景 1、黒 + 基本色 25%」）
Dim x As Long '出力列
Dim y As Long '出力行
Dim temp As Long '一時領域（デフォルトシート数）
Dim strShPageDetail As String 'Excelの場合シート名とページ数の詳細を出力
Dim strWdListString As Variant 'Wordの場合リスト見出し/PowerPointの場合各スライドのタイトル
Dim rngList As Word.Range 'Wordのリスト
Dim rngListNext As Word.Range 'Wordのリスト
'--------------------------------------
'開始メッセージ
'--------------------------------------
MsgRtn = MsgBox("処理を開始しますか？" & vbCrLf & vbCrLf & _
"ページ数を取得可能な拡張子は次の通りです。" & vbCrLf & _
"Excel : xls ,xlsx ,xlsm, xlsb" & vbLf & _
"Word : doc ,docx ,docm" & vbLf & _
"PowerPoint :ppt ,pptx ,pptm" & vbLf & vbLf & _
"[注意]" & vbCrLf & _
"上記拡張子のファイルを開いている場合は、閉じてから実行してください。", _
vbOKCancel + vbInformation, Title:="開始")
If MsgRtn = vbCancel Then Exit Sub
'--------------------------------------
'フォルダを取得
'--------------------------------------
'フォルダダイアログ
Set WSH = CreateObject("WScript.Shell")
DefaultPath = WSH.SpecialFolders("Desktop") & "\" 'デスクトップ。"\"まで入れる。
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = DefaultPath 'デフォルトフォルダをデスクトップにする
If .Show = True Then
strFolderPath = .SelectedItems(1)
End If
End With
'フォルダダイアログで「キャンセル」したので終了
If strFolderPath = "" Then Exit Sub
'フォルダ取得
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder(strFolderPath)
'--------------------------------------
'階層数の指定
'--------------------------------------
Do
MsgRtn = InputBox("階層数を指定してください。" & vbCrLf & vbCrLf & _
"※指定したフォルダの階層を1として、何階層下まで取得するか指定します。デフォルトは1です。", _
"階層数の指定", 1)
'キャンセル
If MsgRtn = "" Then
Exit Sub
End If
'数字
If IsNumeric(MsgRtn) = True Then
'0以下
If MsgRtn <= 0 Then
'もう1度入力
MsgBox "1以上の数値を入力してください。", _
vbOKOnly + vbExclamation, Title:="エラー"
'5以上
ElseIf MsgRtn >= 5 Then
intDepth = CInt(MsgRtn)
MsgRtn = MsgBox(MsgRtn & " 階層が指定されました。ファイルが多い場合には時間がかかりますが、続行しますか？", _
vbOKCancel + vbInformation, Title:="5階層以上指定")
If MsgRtn = vbOK Then
Exit Do
End If
'それ以外
Else
intDepth = CInt(MsgRtn)
Exit Do
End If
'数字以外
Else
MsgBox "1以上の数値を入力してください。", _
vbOKOnly + vbExclamation, Title:="エラー"
End If
Loop
'--------------------------------------
'ファイルリスト取得
'--------------------------------------
Erase FilePaths 'ファイルリスト用変数を初期化
'ファイルリスト取得を呼び出す
GetFileList objFolder, intDepth, 0
On Error Resume Next
lngFileCount = UBound(FilePaths) 'ファイルが1つもない場合UBoundがエラーになる
If Err.Number <> 0 Then
'終了メッセージ
MsgBox "指定されたフォルダにはファイルが1つもないので、終了します。", _
vbOKOnly + vbExclamation, Title:="エラー"
Exit Sub
End If
On Error GoTo 0
'--------------------------------------
'出力ファイル作成
'--------------------------------------
'カーソル砂時計表示
Application.Cursor = xlWait
'新規ブック作成
temp = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set xlsWorkbookOutput = Workbooks.Add
Application.SheetsInNewWorkbook = temp
'シート名
xlsWorkbookOutput.ActiveSheet.Name = "ファイルリスト"
'フォント
xlsWorkbookOutput.Styles("Normal").Font.Name = "ＭＳ ゴシック"
'ルートフォルダ名をA1に出力
With xlsWorkbookOutput.ActiveSheet.Cells(1, 1)
.NumberFormatLocal = "@"
.Value = strFolderPath
End With
'列の幅・見出し設定
x = 3
y = 1
xlsWorkbookOutput.ActiveSheet.Columns(1).ColumnWidth = 5
xlsWorkbookOutput.ActiveSheet.Columns(2).ColumnWidth = 5
xlsWorkbookOutput.ActiveSheet.Columns(3).ColumnWidth = 30
xlsWorkbookOutput.ActiveSheet.Columns(4).ColumnWidth = 80
xlsWorkbookOutput.ActiveSheet.Columns(5).ColumnWidth = 10
xlsWorkbookOutput.ActiveSheet.Columns(6).ColumnWidth = 40
xlsWorkbookOutput.ActiveSheet.Columns(7).ColumnWidth = 10
xlsWorkbookOutput.ActiveSheet.Columns(8).ColumnWidth = 10
xlsWorkbookOutput.ActiveSheet.Cells(x, 1) = "No"
xlsWorkbookOutput.ActiveSheet.Cells(x, 2) = "階層"
xlsWorkbookOutput.ActiveSheet.Cells(x, 3) = "サブフォルダ"
xlsWorkbookOutput.ActiveSheet.Cells(x, 4) = "ファイル名"
xlsWorkbookOutput.ActiveSheet.Cells(x, 5) = "ページ数"
With xlsWorkbookOutput.ActiveSheet.Cells(x, 6)
.Value = "構成情報"
.AddComment
.Comment.Visible = False
.Comment.Text Text:="見出し等構成を知る補助情報。" & vbLf & _
"Excel:シート名,ページ数" & vbLf & "Word:リスト見出し" & vbLf & "PowerPoint:スライド番号,スライドタイトル" & vbLf & _
"Excelのシート名に[非表示]がついてるものは非表示シート"
.Comment.Shape.ScaleWidth 2.5, msoFalse, msoScaleFromTopLeft
.Comment.Shape.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
End With
xlsWorkbookOutput.ActiveSheet.Cells(x, 7) = "サイズ(MB)"
'サイズ(MB)の書式
xlsWorkbookOutput.ActiveSheet.Columns("G:G").NumberFormatLocal = "0.00_ "
'表見出しの背景色
xlsWorkbookOutput.ActiveSheet.Range(Cells(x, 1), Cells(x, 7)).Interior.Color = intColHeadColer
'ウィンドウ枠の固定
xlsWorkbookOutput.ActiveSheet.Cells(x + 1, 1).Select
ActiveWindow.FreezePanes = True
'印刷設定
Application.PrintCommunication = False
With xlsWorkbookOutput.ActiveSheet.PageSetup
.PrintTitleRows = "$1:$3"
.CenterFooter = "&P"
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
Application.PrintCommunication = True
'--------------------------------------
'出力ファイル保存
'--------------------------------------
strDate = Format(Now(), "_yymmdd-hhmm")
strOutputFileName = strBaseName & strDate
i = 0
Do
If FSO.FileExists(DefaultPath & "\" & strOutputFileName & "." & strExtName) = False Then
Exit Do
Else
'ファイル名
i = i + 1
strOutputFileName = strBaseName & strDate & "_" & i
End If
Loop
'ファイルを保存
xlsWorkbookOutput.SaveAs Filename:=DefaultPath & strOutputFileName & "." & strExtName
'--------------------------------------
'ファイル拡張子ごとにページ数取得して出力
'--------------------------------------
For i = 1 To lngFileCount
'ファイルを保存（入力20ファイルごとに出力ファイルを保存）
If i Mod 20 = 0 Then
xlsWorkbookOutput.Save
End If
'ステータスバー表示
Application.StatusBar = Left(Format(i / lngFileCount, "0.0%") & " (" & i & "/" & lngFileCount & ") " & FilePaths(i), 125)
DoEvents
'初期化
lngPageCount = 0
strShPageDetail = ""
strWdListString = ""
'--------------------------------------
'拡張子により場合分け
'--------------------------------------
Select Case LCase(FSO.GetExtensionName(FilePaths(i)))
'Excelファイル
Case "xls", "xlsx", "xlsm", "xlsb"
On Error Resume Next 'ファイルが壊れていて開けないときetc
'ファイルを開く（読み取り専用）
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set xlsworkbook = Workbooks.Open(FilePaths(i), UpdateLinks:=0, ReadOnly:=True)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Clear
Else
On Error GoTo 0
For Each sh In xlsworkbook.Sheets
'ワークシートとグラフシートのページカウントに対応
If TypeName(sh) = "Worksheet" Or TypeName(sh) = "Chart" Then
'非表示シートの場合表示
shVisible = ""
strHiddenSheet = ""
ErrShVisible = False
If sh.Visible <> xlSheetVisible Then
shVisible = sh.Visible '現在の表示状態
On Error Resume Next '保護かかっているブック等でシート表示できないことがあるため回避
sh.Visible = xlSheetVisible '非表示シートを表示
If Err.Number <> 0 Then
ErrShVisible = True
End If
On Error GoTo 0
strHiddenSheet = "[非表示]"
End If
'表示できなかったシートの場合は0ページ
If ErrShVisible = True Then
lngShPageCount = 0
Else
lngShPageCount = sh.PageSetup.Pages.Count
End If
'シート数分のページを加算
lngPageCount = lngPageCount + lngShPageCount
'シート名とページ数
If strShPageDetail = "" Then
strShPageDetail = sh.Name & strHiddenSheet & "," & lngShPageCount
Else
strShPageDetail = strShPageDetail & vbLf & sh.Name & strHiddenSheet & "," & lngShPageCount
End If
If shVisible <> "" And ErrShVisible = False Then
sh.Visible = shVisible '表示状態をもとに戻す
End If
End If
Next sh
'ファイルを閉じる
Application.DisplayAlerts = False
'シートの多いファイルで xlsWorkbook.Close がスルーされてファイルが閉じられないことがあっため
'回避できた Workbooks のファイル名指定でのクローズに修正
Workbooks(FSO.GetFilename(FilePaths(i))).Saved = True
Workbooks(FSO.GetFilename(FilePaths(i))).Close SaveChanges:=xlDoNotSaveChanges
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End If
'Wordファイル
Case "doc", "docx", "docm"
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
On Error Resume Next 'ファイルが壊れていて開けないときetc
'ファイルを開いてページ数取得
Set wordDoc = wordApp.Documents.Open(FilePaths(i), ReadOnly:=True)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Clear
lngPageCount = 0
Else
On Error GoTo 0
'ページ数
lngPageCount = wordDoc.Content.Information(wdNumberOfPagesInDocument)
'見出しを取得（保護されてない文書のみ）
If wordDoc.ProtectionType = wdNoProtection Then
wordDoc.Activate
wordDoc.SelectAllEditableRanges
wordApp.ActiveWindow.Selection.Goto wdGoToHeading, wdGoToFirst '最初の見出し
If wordDoc.Paragraphs.OutlineLevel = wdOutlineLevelBodyText Then '1つも見出しがない
Else
Do
With wordApp.ActiveWindow.Selection
If .Range.ListFormat.ListString <> "" Then
'リスト番号と見出し両方。区切り文字空白。末尾の改行をなしに置換
If strWdListString = "" Then
strWdListString = .Range.ListFormat.ListString & " " & Replace(.Paragraphs(1).Range.Text, vbCr, "")
Else
strWdListString = strWdListString & vbLf & .Range.ListFormat.ListString & " " & Replace(.Paragraphs(1).Range.Text, vbCr, "")
End If
Else
'リスト番号でない場合は出力しない
End If
Set rngList = .Range
Set rngListNext = .GoToNext(wdGoToHeading)
If rngListNext.End = rngList.End Then
Exit Do
End If
End With
Loop
End If
Else
strWdListString = "" '保護文書は見出し空白
End If
'ファイルを閉じる
wordDoc.Close SaveChanges:=False
End If
wordApp.Visible = False
wordApp.Quit
Set wordDoc = Nothing
Set wordApp = Nothing
Set rngList = Nothing
Set rngListNext = Nothing
'Power Pointファイル
Case "ppt", "pptx", "pptm"
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
On Error Resume Next 'ファイルが壊れていて開けないときetc
'ファイルを開いてページ数取得
Set pptPrs = pptApp.Presentations.Open(FilePaths(i), ReadOnly:=True)
If Err.Number <> 0 Then
On Error GoTo 0
Err.Clear
lngPageCount = 0
Else
On Error GoTo 0
lngPageCount = pptPrs.Slides.Count
'スライドタイトル取得
If pptPrs.PageSetup.FirstSlideNumber = 0 Then '開始がスライド0のとき
lngFirstSlideNo = 1
Else
lngFirstSlideNo = pptPrs.PageSetup.FirstSlideNumber
End If
For p = lngFirstSlideNo To pptPrs.Slides.Count
If pptPrs.Slides(p).Shapes.HasTitle Then 'スライドタイトルがあるか
If strWdListString <> "" Then
strWdListString = strWdListString & vbLf & pptPrs.Slides(p).SlideNumber & "," _
& pptPrs.Slides(p).Shapes.Title.TextFrame.TextRange.Text
Else
strWdListString = pptPrs.Slides(p).SlideNumber & "," _
& pptPrs.Slides(p).Shapes.Title.TextFrame.TextRange.Text
End If
End If
Next p
'ファイルを閉じる
With pptPrs
.Saved = True
.Close
End With
Set pptPrs = Nothing
End If
pptApp.Quit
Set pptApp = Nothing
End Select
'--------------------------------------
'結果をExcelに出力
'--------------------------------------
'出力行
x = x + 1
If x Mod 10 = 0 Then
xlsWorkbookOutput.Activate
ActiveWindow.ScrollRow = x '10行に1回スクロール(構成情報が多いと列が高くなる）
End If
'No
xlsWorkbookOutput.ActiveSheet.Cells(x, y).Formula = "=ROW()-3"
'フォルダ名（ルートフォルダは出力しない）
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2).NumberFormatLocal = "@"
If LCase(FSO.GetParentFolderName(FilePaths(i))) = LCase(strFolderPath) Then
'xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2) = ""
Else
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2) = Mid(FSO.GetParentFolderName(FilePaths(i)), Len(strFolderPath) + 2, Len(FSO.GetParentFolderName(FilePaths(i))) - Len(strFolderPath))
End If
'サブフォルダ名を元に階層（サブフォルダ名が正確に取得できないと階層数がおかしくなる）
If xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2) = "" Then
'ルートフォルダは0
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 1) = 0
Else
'ルートフォルダ以外は「"\"の数+1」
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 1) = Len(xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2)) - Len(Replace(xlsWorkbookOutput.ActiveSheet.Cells(x, y + 2), "\", "")) + 1
End If
'ファイル名
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 3).NumberFormatLocal = "@"
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 3) = FSO.GetFilename(FilePaths(i))
'ページ数
If lngPageCount = 0 Then
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 4) = ""
Else
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 4) = lngPageCount
End If
'構成情報
If strShPageDetail <> "" Then
'Excelの場合のシート名とシートページ数
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 5) = strShPageDetail
ElseIf strWdListString <> "" Then
'Wordの場合リスト見出し/PowerPointの場合各スライドのタイトル
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 5) = strWdListString
End If
'サイズ(MB)
xlsWorkbookOutput.ActiveSheet.Cells(x, y + 6).Formula = "=" & FSO.GetFile(FilePaths(i)).Size & "/1024/1024"
Next i
'並び替え（サブフォルダ、ファイル名で並び替え）
xlsWorkbookOutput.ActiveSheet.Cells(3, 1).CurrentRegion.Sort key1:=Range("C4"), Order1:=xlAscending, key2:=Range("D4"), Order1:=xlAscending, Header:=xlYes
xlsWorkbookOutput.Activate
ActiveWindow.ScrollRow = 1
'オートフィルタ
On Error Resume Next
xlsWorkbookOutput.ActiveSheet.Rows("3:3").AutoFilter
On Error GoTo 0
'--------------------------------------
'終了
'--------------------------------------
'ステータスバー表示デフォルト
Application.StatusBar = False
'カーソル砂時計表示解除
Application.Cursor = xlDefault
'ファイルを保存
xlsWorkbookOutput.Save
'ウィンドウアクティブ
AppActivate Application.Caption
'終了メッセージ
EndTime = Now() '終了時刻
MsgBox "終了しました。" & vbLf & vbLf & _
"処理時間：" & Format(EndTime - StartTime, "hh:mm:ss") & vbLf & _
"出力ファイル：" & DefaultPath & xlsWorkbookOutput.Name & vbCrLf & vbCrLf, _
vbOKOnly + vbInformation, Title:="終了"
'オブジェクトクリア
Set WSH = Nothing
Set FSO = Nothing
Set objFolder = Nothing
Set xlsworkbook = Nothing
Set sh = Nothing
Set xlsWorkbookOutput = Nothing
End Sub
Sub GetFileList(objFolder As Object, intDepth As Integer, lngFileCount As Long)
'--------------------------------------
'ファイルリスト取得（再帰呼び出し）
' 結果はモジュールレベル変数「FilePaths」に格納
'--------------------------------------
Dim objSubFolder As Object 'サブフォルダ
Dim objFiles As Object 'ファイル
Dim objF As Object '変数
Dim intNextDepth As Integer '次の階層数
Dim i As Long
Dim FSO As Object 'ファイルシステムオブジェクト
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objSubFolder = objFolder.subFolders
Set objFiles = objFolder.Files
intNextDepth = intDepth - 1
'フォルダ配下
'objSubFolder.Countがとれない特殊フォルダは配下ごと無視
On Error Resume Next
i = objSubFolder.Count
If Err.Number = 0 Then
If objSubFolder.Count > 0 Then
For Each objF In objSubFolder
If intNextDepth > 0 Then
'再帰呼び出し
GetFileList objF, intNextDepth, lngFileCount
End If
Next objF
End If
End If
'ファイル
If objFiles.Count > 0 Then
For Each objF In objFiles
If objF Is Nothing Then
'システム系でNothingが返ってくることがあるので飛ばす
ElseIf Left(objF.Name, 2) = "~$" Then
'~$で始まる一時ファイルは後のページ数取得がエラーになるので飛ばす
ElseIf Left(objF.Name, 1) = "$" Then
'$で始まるファイルは後のページ数取得がエラーになるので飛ばす
Else
'ファイルカウント
lngFileCount = lngFileCount + 1
'ファイルパスを取得するための動的配列を定義
If lngFileCount = 1 Then
ReDim FilePaths(lngFileCount)
Else
ReDim Preserve FilePaths(lngFileCount)
End If
'ファイルパスを配列に格納
FilePaths(lngFileCount) = objF
End If
Next objF
End If
Set objSubFolder = Nothing
Set objFiles = Nothing
Set objF = Nothing
End Sub
フォルダごとに集計する方法
簡単に書いておきます。Excel のピボットテーブルを使うとラクです。
- 「サブフォルダ」列を「¥」区切りで分割するため、「サブフォルダ」列の右に「サブフォルダ」階層分の空の列を追加しておく。
- 「サブフォルダ」列を[データ]-[区切り位置]区切り文字「¥」で分割する。
- 分割した列の見出しが空なので、見出しをつける「サブフォルダ2」、「サブフォルダ3」…等。（ピポットテーブルの仕様として列見出しが必要）
- 表範囲を [挿入]-[ピボットテーブル] に指定する。
- ピボットテーブルの「行」に「サブフォルダ」～「サブフォルダx」等を全て指定する。
- 「値」に「ページ数」を指定する。（自動的に「合計/ページ数」になると思いますが、合計になってなかったら▼で合計を選んでください）
上記は時間ができたらコードに含めようと思っています。
後記
自分が Office 使う範囲で困らない程度に作ってあります。
本当はPDFもページカウントに対応したかったのですが、コメントに書いてる通り厳しそうでした。インターネット上に、ファイルをバイナリで読み込んでページ数の位置を取得するコードがいくつかあったのですが、それだと正しいページがとれないことがありました（何の違いによるものなのか詳細未調査です。正しくとれる場合もありました）。最新PDFに対応したコードを公開してる人もいましたが、かなり長いソースで煩雑になりそうなため、入れるのを諦めました。
変更履歴
1.1 2021/07/22 バグ修正及び一部仕様変更しました。
1.2 2021/08/03 バグ修正及び一部仕様変更しました。
1.3 2021/08/05 バグ修正しました。
1.4 2021/10/09 バグ修正しました。
