読者です 読者をやめる 読者になる 読者になる

Excelの印刷ページ数を取得する VBAメモ

VBA

指定したフォルダ配下のファイル一覧を取得し、Excelファイルなら印刷ページ数を取得する。

参考サイト
http://d.hatena.ne.jp/asuka0801/20110605/1307232920
http://www.moug.net/tech/exvba/0150117.html

Dim cnt As Long
Dim pageCount As Integer
Dim xlApp As Excel.Application
Dim objBooks As Excel.Workbooks
Dim sh As Excel.Worksheet
Sub test()
    Set xlApp = New Excel.Application
    Set objBooks = xlApp.Workbooks
    cnt = 0
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            FolderSearch .SelectedItems(1)
            If Not objBooks Is Nothing Then objBooks.Close
            'Excelを閉じる
            If Not xlApp Is Nothing Then xlApp.Quit
        End If
    End With
    Application.ScreenUpdating = True
    Set sh = Nothing
    Set objBooks = Nothing
    Set xlApp = Nothing
End Sub
Public Sub FolderSearch(Path As String)
    Dim objBook As Excel.Workbook
    Dim buf As String, f As Object
    buf = Dir(Path & "\*.*")
    Do While buf <> ""
        'SVN管理ファイルやWindows管理ファイルを無視する
        If InStr(buf, "svn") = 0 And InStr(buf, "Thumbs") = 0 Then
            cnt = cnt + 1
            Cells(cnt, 1) = Path & "\" & buf
            pagecnt = 0
            pos = InStrRev(buf, ".")
            'xls、xlsx等のファイルを対象とする
            'xls123等のファイルがない前提
            If LCase(Mid(buf, pos + 1)) Like "xls*" Then
                Set objBook = objBooks.Open( _
                        Filename:=Path & "\" & buf, _
                        UpdateLinks:=False, _
                        ReadOnly:=True, _
                        IgnoreReadOnlyRecommended:=True)
                For Each sh In objBook.Sheets
                    '非表示シートは印刷ページカウント対象としない
                    If sh.Visible = True Then
                        sh.Select
                        ActiveWindow.View = xlPageBreakPreview
                        pagecnt = pagecnt + xlApp.ExecuteExcel4Macro("get.document(50)")
                    End If
                Next
                'Workbookを閉じる
                If Not objBook Is Nothing Then objBook.Saved = True
                If Not objBook Is Nothing Then objBook.Close
            End If
            Cells(cnt, 2) = pagecnt
        End If
        buf = Dir()
    Loop
    Set objBook = Nothing
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            Call FolderSearch(f.Path)
        Next f
    End With
End Sub