めも

パスワードを思い出したので、メモ再開

複数のMS-Wordのドキュメントを１つにまとめる

IT Windows Microsoft VBScript

たくさんあるMS-Wordのドキュメントを１つにまとめたくてスクリプト作ってみた。
でもいまいちだな。
セクション単位で追加してるけど、印刷設定は元のドキュメントを引き継いでくれないから、
常に先頭の印刷書式に依存してしまう。
全部同じなら使えそうなので、一応メモしておく。
（エラーとはか考えてない）

Option Explicit

' 検索対象ファイル拡張子
Dim targetFileExp
targetFileExp = Array("doc", "docx")

Dim objFso
Set objFso = CreateObject("Scripting.FileSystemObject")

Dim objWord
Set objWord = CreateObject("Word.Application")

Dim objNewDoc
Dim strInFile
Dim strOutFile

dim objSelection

' 一応見せておく
objWord.Visible = True

' カレントディレクトリのファイルリストから抽出する
Dim exp
Dim file

For Each exp in targetFileExp
    For Each file In objFso.GetFolder("./").Files
        if UCase(objFso.GetExtensionName(file)) = UCase(exp) Then
            strInFile = file.path
            If strOutFile = "" Then
                ' 親フォルダ名を結合ファイル名に
                strOutFile = objFso.BuildPath( file.ParentFolder , objFso.GetFileName(file.Name) & "_ALL." & objFso.GetExtensionName(file) )
                WScript.Echo "doc結合：" & strOutFile
                'Set objNewDoc = objWord.Documents.Add                      ' 新規の場合はこっち
                Set objNewDoc = objWord.Documents.Open(strInFile)           ' 先頭の書式に合わせる場合はこっち
                Set objSelection = objWord.Selection
            Else
                WScript.Echo "　　＋：" & file.Name

                objSelection.InsertFile(strInFile)
                objSelection.InsertParagraphAfter
                objSelection.InsertBreak(2)             ' 2:wdSectionBreakNextPage
                objSelection.Collapse(0)
            End if

        End If
    Next
Next

objSelection.WholeStory() 
objSelection.Fields.Update()

objNewDoc.SaveAs2 strOutFile
objNewDoc.Close

objWord.Quit

set objFso = Nothing
set objNewDoc = Nothing
set objWord = Nothing

MsgBox "終了"

※はてな記法のシンタックスハイライトにVBScriptが無いので、vbで表示