コピペプログ

VBA、VBS、バッチファイルなどの備忘録と日記です。

【VBS】Word・Excel・PowerPointをPDFに一括変換する【VBScript】

Excel Word PowerPoint VBScript PDF 開発

ネット上で見つけた便利なコードを改造。 ドラッグアンドドロップでフォルダ内のofficeファイルをPDFに変換します。 仕事で大量のＷｏｒｄファイルやＥｘｃｅｌファイルのマニュアルをＰＤＦに変換することに… 先人のコードを参考に機能を付け足して作りました。

【欲しかった機能】

  • フォルダドロップ

  • サブフォルダ内も実行

  • ファイルのあるフォルダ内に変換後のファイルを作成

  • 変換前と同じファイル名

  • 処理中の表示

Option Explicit
'IE の宣言と初期化
Dim ie
initializeIe()
updateMsg "処理を開始します..."

'------------------------------------------------
'ドラッグ&ドロップされたフォルダの処理
Dim Args  

Set Args = WScript.Arguments
If Args.Count <> 1 Then '処理できるのは１フォルダのみ
    WScript.Echo "当スクリプトに対象となる１フォルダをドラッグ&ドロップして処理を実行してください。"
    WScript.Quit    'スクリプトを終了
End If

'フォルダ判別
With CreateObject("Scripting.FileSystemObject") '以下の処理はEnd WithまでScripting.FileSystemObjectを使用
    If .FolderExists(Args(0)) = False Then  'ドラッグされたものを解析
        WScript.Echo "フォルダが見つかりません。" & vbCrLf & "あるいはフォルダではありません。"
        closeIe()
        WScript.Quit
    End If
End With

'officeファイルの有無チェック「IsExistsParticularFile」に処理渡した結果下で処理
If (IsExistsParticularFile(Args(0), "doc") = False) And _
    (IsExistsParticularFile(Args(0), "docx") = False) And _
    (IsExistsParticularFile(Args(0), "xls") = False) And _
    (IsExistsParticularFile(Args(0), "xlsx") = False) And _
    (IsExistsParticularFile(Args(0), "xlsm") = False) And _
    (IsExistsParticularFile(Args(0), "ppt") = False) And _
    (IsExistsParticularFile(Args(0), "pptx") = False) Then
    WScript.Echo "指定したフォルダ内にOFFICEファイルが見つかりませんでした。"
    closeIe()
    WScript.Quit
End If

' 処理…
updateMsg "PDF変換処理を実行しています..."
WScript.Sleep 5000  ' サンプル用・処理している風に少し止める

ConvertWordToHtml Args(0) 'WordToHtmlへWScript.Argumentsを渡して呼び出し。フォルダパスとかファイル名とか。

' 完了
updateMsg "スクリプト処理完了!"
WScript.Echo "処理が終了しました。"
' IE を終了させスクリプトを閉じる
closeIe()
WScript.Quit
'---------------------------------------------------------------
Private Sub ConvertWordToHtml(ByVal FolderPath)
'指定したフォルダ内のWordファイルをPDFファイルに変換
Dim wdApp, wdDoc, exApp, exBook, pwApp, pwSs
Dim f

Const msoFalse = 0
Const msoTrue = -1
Const xlTypePDF = 0
Const xlQualityStandard = 0
Const wdExportFormatPDF = 17
Const wdExportOptimizeForPrint = 0
Const wdExportAllDocument = 0
Const wdExportDocumentContent = 0
Const wdExportCreateWordBookmarks = 2
Const wdDoNotSaveChanges = 0

Set wdApp = CreateObject("Word.Application")     'Wordのオブジェクトを作成
Set exApp = CreateObject("Excel.Application")     'Excelのオブジェクトを作成
Set pwApp = CreateObject("PowerPoint.Application")     'PowerPointのオブジェクトを作成
wdApp.Visible = False 'Wordアプリを非表示
exApp.Visible = False 'Excelアプリを非表示
pwApp.Visible = True 'PowerPointアプリを非表示
pwApp.WindowState = 2 'ppWindowMinimized 
  
If Right(FolderPath, 1) <> ChrW(92) Then FolderPath = FolderPath & ChrW(92) 'FolderPath末尾￥をつける処理 ChrW(92)は「￥」Chr 【ｷｬﾗｸﾀｰ】関数
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(FolderPath).Files 'ファイルの数だけ繰り返し処理
            Select Case LCase(.GetExtensionName(f)) 'ファイル形式が当てはまれば処理
        'Wordファイルのみ処理
            Case "doc", "docx"
                Set wdDoc = wdApp.Documents.Open(CStr(f)) 'Wordで対象ファイルを開く
                wdDoc.ExportAsFixedFormat FolderPath & .GetBaseName(f) & ".pdf", wdExportFormatPDF, False'HTM形式で保存する
                wdDoc.Close wdDoNotSaveChanges '対象ファイル閉じる
                Set wdDoc = Nothing '変数の片付け
            Case "xls", "xlsx", "xlsm"
                Set exBook = exApp.Workbooks.Open(CStr(f)) 'Excelで対象ファイルを開く
                exBook.ExportAsFixedFormat xlTypePDF, FolderPath & .GetBaseName(f) & ".pdf", xlQualityStandard, False, False, , , False 
                exBook.Close wdDoNotSaveChanges '対象ファイル閉じる
                Set exBook = Nothing '変数の片付け
            Case "ppt", "pptx"
                Set pwSs = pwApp.Presentations.Open(CStr(f)) 'PowerPointで対象ファイルを開く
                pwSs.SaveAs, FolderPath & .GetBaseName(f) & ".pdf", ppSaveAsPDF, msoTrue '
                pwSs.Close wdDoNotSaveChanges '対象ファイル閉じる
                Set pwSs = Nothing '変数の片付け
        End Select
    Next
End With
wdApp.Quit 'Wordアプリを終了
exApp.Quit 'Excelアプリを終了
pwApp.Quit 'PowerPointアプリを終了

End Sub
'------------------------------------------------------------------------------------------------------------------

Private Function IsExistsParticularFile(ByVal FolderPath, ByVal FileExtension)
'指定したフォルダ内に特定の拡張子のファイルがあるかを調べる
Dim ret
Dim f
 
ret = False '初期化
With CreateObject("Scripting.FileSystemObject")
    For Each f In .GetFolder(FolderPath).Files
        Select Case LCase(.GetExtensionName(f))
        Case LCase(FileExtension)
            ret = True
            Exit For
        End Select
    Next
End With
IsExistsParticularFile = ret
End Function
'------------------------------------------------------------------------------------------------------------------
' IE の初期化
Sub initializeIe()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Navigate("about:blank")
    .ToolBar = False
    .StatusBar = False
    ' 幅・高さの設定
    .Width = 300
    .Height = 200
    ' 画面右上に配置する。"parentWindow.screen" はパスカルケースで書くと認識されない
    .Top = 0
    .Left = .Document.parentWindow.screen.Width - 300
    .Document.Charset = "UTF-8"
    .Visible = True
    .Document.Title = "スクリプト実行中"
  End With
End Sub
'------------------------------------------------------------------------------------------------------------------
' メッセージを IE に追記する
' 引数のメッセージを IE の最終行に追記する。
' 最終行が表示されるようにスクロール位置を最下部に設定する。
Sub updateMsg(value)
  With ie
    .Document.Body.innerHTML = .Document.Body.innerHTML & value & "<br>"
    .Document.Script.setTimeout "javascript:scrollTo(0," & .Document.Body.ScrollHeight & ");", 0
  End With
End Sub

' IE を終了する
Sub closeIe()
  ie.Quit
  Set ie = Nothing
End Sub