VBScriptでWordファイルのページ数一覧を作ってみる

2017年11月25日2025年3月2日

ある日、大量のWordファイルで作られた資料の中身を目視確認する必要に迫られました。

複数人で分担して実施するのですがファイル毎にボリューム(ページ数)が異なるためファイル数で割り振ると不公平が発生します。

そこで事前にファイル単位のページ数がわかるといいなぁということでページ数の一覧を生成するスクリプトを作ってみました。

ソースコード

作成したスクリプトはスクリプトを実行したディレクトリ配下にあるWordファイルを検索しページ数を取得して結果をファイル出力します。

Wordファイルのページ数はBuiltinDocumentPropertiesで取ってこれます。

下記を参考にしました。

www.relief.jp

文字コードはSJISなので注意です。(UTF-8だと実行時に日本語を扱っている行で怒られます。)

'
'VBScript File
'Character code is SJIS
'

Option Explicit

Call Main()

'
'@func Main
'@brief メイン関数
'
Sub Main()
  'ファイルシステムオブジェクトの生成
  Dim fso 
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  'カレントDIR配下にあるWordファイルのページ数を取得
  Dim result
  result = GetNumberOfWordFilePageAll(fso, fso.GetFolder("."))
  
  '結果をファイルに出力
  Dim ret
  ret = WriteResultToFile(fso, "result.csv", result)
  
End Sub

'
'@func GetNumberOfWordFilePageAll
'@brief カレントDIRにあるWordファイルのページ数を取得する
'@param[in] dir  ディレクトリパス
'@param[in] fso  ファイルシステムオブジェクト
'
Function GetNumberOfWordFilePageAll(fso, dir)
  
  Dim result
  result= ""
  
  ' カレントDIRにあるwordファイルのページ数を数える
  Dim File
  For Each File in dir.Files
    result= result& GetNumberOfWordPages(fso, File.path)
  Next
  
  ' カレントDIR配下にあるDIRに対して再帰的に実行する
  Dim Subdir
  For Each Subdir in dir.SubFolders
    ' 再帰呼び出し
    result= result& GetNumberOfWordFilePageAll(fso, Subdir)
  Next
  
  GetNumberOfWordFilePageAll = result
  
End Function

'
'@func GetNumberOfWordPages
'@brief Wordファイルのページ数を取得する
'@param[in] fso       ファイルシステムオブジェクト
'@param[in] filepath  対象ファイル
'
Function GetNumberOfWordPages(fso, filepath)
  
  '拡張子のチェック(wordファイル以外は対象外)
  Dim ExtName
  ExtName = UCase(fso.GetExtensionName(filepath))
  If Not (ExtName = "DOC" OR ExtName = "DOCX") Then
    Exit Function
  End If
  
  ' wordファイルを開く
  Dim wordApp
  Set wordApp = WScript.CreateObject("Word.Application")
  Dim doc
  Set doc = wordApp.Documents.Open(filepath)
  
  ' ファイル名,ページ数を返す
  GetNumberOfWordPages = filepath & "," & doc.BuiltInDocumentProperties(14) & vbNewLine
  
  ' wordファイルを閉じる
  doc.Close
  Set doc = Nothing
  wordApp.Quit
  Set wordApp = Nothing
  
End Function


' @func WriteResultToFile
' @brief 処理結果をファイルに出力
' @param[in] fso      ファイルシステムオブジェクト
' @param[in] filename 出力ファイル名
' @param[in] result   処理結果
'
Function WriteResultToFile(fso, filename, result)
  
  Dim file
  Set file = fso.CreateTextFile("." & "\" & filename)
  Dim header
  header = UCase("ファイル名, ページ数")
  file.WriteLine(header)
  file.WriteLine(result)
  file.close
  Set file = Nothing
  
  MsgBox "処理結果を '" & filename & "' に出力しました。"
  
End Function