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