VBA 複数Word→PDF変換→Zip圧縮

質問

同一ファイル複数のWordファイルを全てPDFに変換した後、できあがったPDFをまとめてZipで圧縮しするVBAを考えています。

VBA初心者ですが、このやり方で業務効率化ができればと考えています。
良い方法があれば教えてください。

回答No.3

nda23 · ベストアンサー

前回のPDF出力の訂正です。
PrintOut後にパイプを作っていましたが、
先にパイプを作ってからPrintOutの方が
安全ですね。
ZIP圧縮は以下の通りです。

Declare Sub Sleep Lib "KERNEL32" (ByVal ミリ秒 As Long)

Sub ZIP圧縮()
Dim シェル As Object
Dim 空間 As Object
Dim I As Long
Dim 名前 As String

'空のZIPファイルを作成する
名前 = 対象パス & "文書.zip"
Open 名前 For Output As #1
Print #1, "PK"; Chr(5); Char(6); String(18, 0);
Close #1
'シェルをインスタンス化する
Set シェル = CreateObject("Shell.Application")
'ZIPファイル空間を取得する
Set 空間 = シェル.NameSpace(名前)
'ファイルを個別に処理する
Do Until I>= 個数
　　'ファイル名を設定する
　　名前 = 対象パス & Replace(一覧(I), ".doc", ".pdf")
　　'ZIPファイルに追加する
　　空間.CopyHere 名前
　　'インデックスを更新
　　I = I + 1
　　'ZIPファイル内のファイル数が更新されるのを待つ
　　Do Until 空間.Items.Count >= I
　　　　'1ミリ秒待機する
　　　　Sleep 1
　　Loop
Loop
End Sub

回答No.2

nda23

Const PDF処理クラス名 　　　　As String = "Bullzip.PDFPrinterSettings"
Const PIPE_ACCESS_INBOUND 　　As Long = 1 'パイプ転送：クライアント→サーバ
Const PIPE_TYPE_BYTE 　　　　 As Long = 0 'パイプ操作：バイトストリーム
Const PIPE_READMODE_BYTE 　　 As Long = 0 'パイプ操作：バイト単位読込み
Private Type 記述子
　　サイズ　　　　　　　　 As Long　　 '構造体サイズ
　　ポインタ　　　　　　　　As Long　　 '継承データへのポインタ(未使用)
　　継承　　　　　　　　　　As Long　　 '継承有無
End Type
'名前付きパイプを作成する
Private Declare Function CreateNamedPipe Lib "KERNEL32" Alias "CreateNamedPipeA" _
　　(ByVal パイプ名 As String, _
　　 ByVal 開くモード As Long, _
　　 ByVal 固有モード As Long, _
　　 ByVal インスタンス数 As Long, _
　　 ByVal 出力バッファ長 As Long, _
　　 ByVal 入力バッファ長 As Long, _
　　 ByVal タイムアウト As Long, _
　　 ByRef セキュリティ記述子 As 記述子) As Long
'ハンドルの閉鎖
Private Declare Function CloseHandle Lib "KERNEL32" _
　　(ByVal ハンドル As Long) As Long
'ファイルの読込み
Private Declare Function ReadFile Lib "KERNEL32" _
　　(ByVal ハンドル As Long, _
　　 ByVal バッファ As String, _
　　 ByVal 指定バイト数 As Long, _
　　 ByRef 読込バイト数 As Long, _
　　 ByVal オーバーラップ As Long) As Long
'パイプ接続待機
Private Declare Function ConnectNamedPipe Lib "KERNEL32" _
　　(ByVal ハンドル As Long, _
　　 ByVal オーバーラップ As Long) As Long
'******************
Const 対象パス As String = "D:\～\"
Dim 個数 As Long
Dim 一覧() As String
'****** ファイル一覧の取得
Sub ファイル一覧取得
Dim 名前
個数 = -1
Erase 一覧
名前 = Dir(対象パス & "*.doc")
Do Until 名前 = ""
　　個数 = 個数 + 1
　　ReDim Preserve 一覧(個数)
　　一覧(個数) = 名前
　　名前 = Dir
End Sub
'****** PDFプリンタに出力
Sub PDF出力()
Dim 現プリンタ As String
Dim PDFプリンタ As String
Dim PDFセッタ As Object
Dim 継承有無　　As 記述子
Dim パイプ名　　As String
Dim ハンドル　　As Long
Dim I　　　　 As Long
Dim 文書　　　　As Document
Dim バッファ　　As String
Dim バイト数　　As Long

'★PDFプリンタ名を取得する
PDFプリンタ = PDFプリンタ名取得
If PDFプリンタ名 = "" Then
　　MsgBox "Bullzip PDF Printer が見つかりません", vbCritical
　　Exit Sub
End If
'★オブジェクトをインスタンス化してみる
On Error Resume Next
Set PDFセッタ = CreateObject(PDF処理クラス名)
On Error GoTo 0
If PDFセッタ Is Nothing Then
　　MsgBox PDF処理クラス名 & "をインスタンス化できません", vbCritical
　　Exit Sub
End If
Set PDFセッタ = Nothing
'★現在のプリンタを記録する
現プリンタ = Application.ActivePrinter
'★Bullzip PDF Printerにする
Application.ActivePrinter = PDFプリンタ
'★パイプ名を設定する
パイプ名 = "\\.\PIPE\MyPipe"
'★パイプはプロセス間継承するので記述子を設定する
継承有無.サイズ = Len(継承)
継承有無.継承 = 1
'★一覧のファイルを処理する
For I = 0 To 個数
　　'★オブジェクトをインスタンス化する
　　Set PDFセッタ = CreateObject(PDF処理クラス名)
　　'★出力するPDFファイルのパス
　　PDFセッタ.SetValue "Output", 対象パス & Replace(一覧(I), ".doc", ".pdf")
　　'★処理結果ファイルの出力先
　　PDFセッタ.SetValue "StatusFile", パイプ名
　　'★設定を表示しない
　　PDFセッタ.SetValue "ShowSettings", "never"
　　'★変換後PDFファイルを開かない
　　PDFセッタ.SetValue "ShowPDF", "no"
　　'★PDFファイルの上書き確認をしない
　　PDFセッタ.SetValue "ConfirmOverwrite", "no"
　　'★終了時メッセージを表示しない
　　PDFセッタ.SetValue "ShowProgressFinished", "no"
　　'★設定を書き込む
　　PDFセッタ.WriteSettings True
　　'★DOCファイルを開く
　　Set 文書 = Documents.Open(対象パス & 一覧(I))
　　'★開いたDOCファイルを印刷する
　　文書.PrintOut
　　’★DOCファイルを閉じる
　　文書.Close
　　'★名前付きパイプを作成する
　　ハンドル = CreateNamedPipe(パイプ名, PIPE_ACCESS_INBOUND, _
　　　　　　　　　　　　 PIPE_TYPE_BYTE Or PIPE_READMODE_BYTE, _
　　　　　　　　　　　　 2, 1, 1, 0, 継承有無)
　　'★Bullzip PDF Printerがパイプを開くのを待つ
　　ConnectNamedPipe ハンドル, 0
　　'★Bullzip PDF Printerがパイプを閉じるまで空読みする
　　バッファ = Space(1024)
　　Do Until ReadFile(ハンドル, バッファ, 1024, バイト数, 0) = 0
　　Loop
　　'★ハンドルを閉じる
　　CloseHandle ハンドル
　　'★念のため後始末
　　Set PDFセッタ = Nothing
Next
'★プリンタを元に戻す
Application.ActivePrinter = 現プリンタ
End Sub

名前付きパイプのパイプ名はプロセスIDや時刻を入れて
なるべく一意になるようにしてください。サンプルは
横着して固定の名前になっています。
印刷中にキャンセルされたり不測の事態が起きた場合の
対応はしてありません。

ZIPに入れるのは次回になります。

回答No.1

nda23

>同一ファイル複数のWordファイル
「同一フォルダ内の複数のWordファイル」では？

Word→PDFは色々なツールがネット上にあり
ますが、プログラムから手を突っ込んで色々
いじれるものはあまりありません。
Bullzip PDF Printer はこれができるので、
よく使っています。

プログラムは実はとても難しく、とても長いので、
理屈を説明します。

(1)PDFプリンタの存在を確かめる。
　存在しない場合は終了する。
(2)ファイル名一覧を作る。
　フォルダ内を検索して*.docの配列を作る
(3)現在のプリンタをPDFプリンタにする。
(4)ファイル名一覧から１個ずつ処理する。
　(4-1)docファイルを開く。
　(4-2)印刷する。
　(4-3)docファイルを閉じる。
　(4-4)同名のPDFファイル名一覧を作る。
(5)現在のプリンタに戻す。
(6)ZIP初期ファイルを作る。
(7)PDFファイル名一覧から１個ずつ処理する。
　(7-1)ZIPファイルの名前空間にPDFファイルをコピーする。
　(7-2)ZIPファイルの名前空間の項目数が増えるのを待つ。

ここで、「PDFプリンタの存在を確かめる」などと
一言で書いてありますが、レジストリを列挙して
プリンタ名とデバイスを取得するので、相当に
長い処理です。また、PDF処理中に次の印刷を
するとデータが壊れるため、(4-3)の後にPDFの
出力完了を待ち合わせます。これは名前付きの
パイプを利用して処理します。ZIPを作るステップは
とても簡単で、空のZIPファイルを作り、ここにコピー
する感じでOKです。
最初にPDFプリンタ名を求める処理です。

'定義
Const PDFドライバ名 As String = "Bullzip PDF Printer"
'API定義
Const HKE_LOCAL_MACHINE As Long = &H80000002
Const KEY_READ As Long = &H20019
Const プリンタフォルダ As String = _
"SOFTWARE\Microsoft\Windows NT\CurrentVersion\Print\Printers"
Const ドライバエントリ As String = "Printer Driver"
Private Declare Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" _
(ByVal ルート As Long, ByVal ディレクトリ As String, ByVal 予約 As Long, _
ByVal マスク As Long, キー As Long) As Long
'レジストリキーの列挙
Private Declare Function RegEnumKeyEx Lib "ADVAPI32" Alias "RegEnumKeyExA" _
(ByVal キー As Long, ByVal 索引 As Long, ByVal 名前 As String, _
ByRef 名前長 As Long, ByVal 予約1 As Long, ByVal 値領域 As Long, _
ByVal 領域長 As Long, ByVal 更新日時 As Long) As Long
'レジストリの文字型の値を取得
Private Declare Function RegQueryValueEx Lib "ADVAPI32" Alias "RegQueryValueExA" _
(ByVal キー As Long, ByVal エントリ名 As String, ByVal 予約 As Long, _
ByRef 形式 As Long, ByVal 領域 As String, ByRef バイト数 As Long) As Long
'レジストリを閉じる
Private Declare Function RegCloseKey Lib "ADVAPI32" (ByVal キー As Long) As Long
'システム初期化ファイルの読込み(古い方法)
Private Declare Function GetProfileString Lib "KERNEL32" Alias "GetProfileStringA" _
(ByVal 節名 As String, ByVal 段落名 As String, ByVal 規定値 As String, _
ByVal 取得領域 As String, ByVal バイト数 As Long) As Long
'文字列のANSIとしてのバイト数応答（文字列を使用）
Private Declare Function lstrlen Lib "KERNEL32" Alias "lstrlenA" _
(ByVal 文字列 As String) As Long
'ANSIバイト列の文字列を内部形式で返す
Private Declare Function SysAllocStringByteLen Lib "OLEAUT32" _
(ByVal 原始データ As String, ByVal バイト数 As Long) As String

Function PDFプリンタ取得() As String
Dim 親キー　　　As Long
Dim 子キー　　　As Long
Dim 番号　　　　As Long
Dim 戻り値　　　As Long
Dim 検出フラグ　As Boolean
Dim 取得領域　　As String
Dim プリンタ　　As String
Dim バイト数　　As Long
Dim データ型　　As Long
Dim 情報配列　　As Variant

'レジストリのプリンタ一覧ディレクトリを開く
戻り値 = RegOpenKeyEx(HKE_LOCAL_MACHINE, プリンタフォルダ, 0, KEY_READ, 親キー)
'開けない時は終了する
If 戻り値 <> vbNormal Then Exit Function
'プリンタを列挙する
Do
　　取得領域 = Space(256)
　　バイト数 = Len(取得領域)
　　戻り値 = RegEnumKeyEx(親キー, 番号, 取得領域, バイト数, 0, 0, 0, 0)
　　If 戻り値 <> vbNormal Then Exit Do
　　プリンタ = SysAllocStringByteLen(取得領域, lstrlen(取得領域))
　　'プリンタのディレクトリを開く
　　戻り値 = RegOpenKeyEx(親キー, プリンタ, 0, KEY_READ, 子キー)
　　If 戻り値 = vbNormal Then
　　　　'ドライバ名を取得する
　　　　バイト数 = Len(取得領域)
　　　　戻り値 = RegQueryValueEx(子キー, ドライバエントリ, 0, _
　　　　　　　　　　　　　　　　 データ型, 取得領域, バイト数)
　　　　If 戻り値 = vbNormal Then
　　　　　　取得領域 = SysAllocStringByteLen(取得領域, lstrlen(取得領域))
　　　　　　'ドライバ名が一致したら検出とし、列挙を止める
　　　　　　If 取得領域 = PDFドライバ名 Then
　　　　　　　　検出フラグ = True
　　　　　　End If
　　　　End If
　　　　'子キーを閉じる
　　　　RegCloseKey 子キー
　　End If
Loop Until 検出フラグ
'親キーを閉じる
RegCloseKey 親キー
'検出しなかった場合は終了する
If Not 検出フラグ Then Exit Function
'PDFプリンタのポート名を取得する
取得領域 = Space(256)
バイト数 = GetProfileString("devices", プリンタ, "", 取得領域, Len(取得領域))
'もしインストールされていなければ終了する
If バイト数 = 0 Then Exit Function
'文字列を作り直す
取得領域 = SysAllocStringByteLen(取得領域, バイト数)
'カンマで区切る
情報配列 = Split(取得領域, ",")
'最後の要素をデバイスにする
PDFプリンタ取得 = プリンタ & " on " & 情報配列(UBound(情報配列))
End Function

この関数の戻り値をActivePrinterに設定すれば
Bullzip PDF Printer への出力になります。
空文字列が返る場合はインストールされていない
時です。

運用上、「通常使うプリンタ」にBullzip PDF Printerを
設定することをルールにするなら、こういう処理は
不要です。しかし、実務上はこれくらいのチェックは
必要です。

続きが見たい場合は補足を書いてください。

補足

>「同一フォルダ内の複数のWordファイル」では？
そうです、失礼いたしました。

想像していたよりもずっと難しい処理だったのですね。
長い構文ありがとうございます。
初心者なりに理解できるよう勉強させてもらっています。

ぜひ続きを見たいのでよろしくお願いいたします。