2022年4月、「Wordマクロで、PDFをA6サイズに変換する 」を書きました。自分で使っていて不便な点がありましたので改良版を紹介します。
従来の問題点・変更点
・加工途中に何度もOKをクリックしなくてはならない。
ずっとPCの画面を監視しなくてはならず、
時間がもったいない。
→途中でのクリック不要。進捗はブック内に記載。
・生成したPDFの名前が長すぎると、Kindleで一覧表示
したときに、末尾まで見えず、全部同じ名前に見えてしまう。
→PDFの名前の長さを制限。
マクロ
Function PDFファイルを開く(ByVal dir1 As String) As Boolean
'参考 https://ameblo.jp/gidgeerock/entry-12059401800.html
'【Wordマクロ】指定したフォルダからファイルを選択して開く
Dim file1 As String, file2 As String
Dim myFD As FileDialog
Dim myFolderPath As String
PDFファイルを開く = False
file1 = ActiveDocument.Name
'MsgBox "「PDFからWordに変換します」 をOKしてから、" & vbLf & _
'"変換完了まで 6分程度かかることがあります。(サイズによる)"
myFolderPath = dir1 'フォルダパスを設定
'ファイルの選択ダイアログ
Set myFD = Application.FileDialog(msoFileDialogFilePicker)
With myFD
'ダイアログボックスのタイトルを設定
.Title = "ファイルを選択してください"
'複数ファイルの選択をオフ
.AllowMultiSelect = False
'表示するファイルの種類の設定
With .Filters
.Clear
' .Add "すべてのWordファイル", "*.doc; *.docx"
.Add "すべてのPDFファイル", "*.pdf"
End With
'最初に表示するフォルダを設定
.InitialFileName = myFolderPath
'ファイルを選択して「OK」ボタンをクリックした場合の処理
If .Show = -1 Then
Documents.Open FileName:=.SelectedItems(1)
End If
'表示するファイルの種類の設定を解除
.Filters.Clear
End With
Set myFD = Nothing
If ActiveDocument.Name = file1 Then '開いてない
Exit Function
End If
PDFファイルを開く = True '成功、と返す
End Function
Function WORDファイルをダイアログで開く(ByVal dir1 As String) As Boolean
Dim file1 As String, file2 As String
Dim myFD As FileDialog
Dim myFolderPath As String
WORDファイルをダイアログで開く = False
file1 = ActiveDocument.Name
'フォルダパスを設定
myFolderPath = dir1
'ファイルの選択ダイアログ
Set myFD = Application.FileDialog(msoFileDialogFilePicker)
With myFD
'ダイアログボックスのタイトルを設定
.Title = "分割前のWORDファイルを選択してください"
'複数ファイルの選択をオフ
.AllowMultiSelect = False
'表示するファイルの種類の設定
With .Filters
.Clear
.Add "すべてのWordファイル", "*.doc; *.docx"
End With
'最初に表示するフォルダを設定
.InitialFileName = myFolderPath
'ファイルを選択して「OK」ボタンをクリックした場合の処理
If .Show = -1 Then
Documents.Open FileName:=.SelectedItems(1)
End If
'表示するファイルの種類の設定を解除
.Filters.Clear
End With
Set myFD = Nothing
If ActiveDocument.Name = file1 Then '開いてない
Exit Function
End If
WORDファイルをダイアログで開く = True
End Function
Sub PDFで保存(ByVal dir1 As String, ByVal file1 As String)
If Right(dir1, 1) <> "\" Then
dir1 = dir1 & "\"
End If
'PDFで保存
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
dir1 & file1, ExportFormat:= _
wdExportFormatPDF
'保存直後に、自動的にPDFが開いてしまうのを防止するには、
'印刷設定の印刷先Acrobatの設定で、「結果のPDFを表示」をオフにする。
End Sub
Sub PDFを読み込んでDOCXで保存()
'ボタンで呼び出される。
'Private Sub CommandButton1_Click()
' Call PDFを読み込んでDOCXで保存
'End Sub
Dim dir0 As String, file0 As String, dir1 As String, file1 As String, file2 As String
Dim p_ALL As Long
Application.Move Left:=1, Top:=0 'ウインドウを左上寄せにする。
Application.Resize Width:=528, Height:=328
'マクロファイルについて
dir0 = ActiveDocument.Path '開くダイアログで最初に表示されるフォルダ
file0 = ActiveDocument.Name
'------------------------------------
If PDFファイルを開く(dir0) = False Then
Exit Sub '開くのをキャンセルしたら先に進まないよう停止
End If
'開いてからの、PDFファイルの場所と名前を取得
dir1 = ActiveDocument.Path
file1 = ActiveDocument.Name
If Right(file1, 3) <> "pdf" And Right(file1, 3) <> "PDF" Then
MsgBox "PDFではありません。"
Exit Sub
End If
Call 文書末尾に追記("PDFを読み込んでDOCXで保存 開始。", file0)
'保存予定の名前を作成
file2 = Replace(Replace(file1, ".pdf", ""), ".PDF", "") & ".docx"
If Dir(dir1 & "\" & file2) <> "" Then 'ファイルが既存の場合
'MsgBox file2 & "は既にあります。別の名前にします。"
file2 = Replace(file2, ".docx", "_" & Format(Time, "hhmm") & ".docx") '時刻つきに。
End If
'MsgBox "名前をつけて保存します " & vbLf & dir1 & vbLf & file2
ActiveDocument.SaveAs FileName:=dir1 & "\" & file2 '名前を付けて保存
p_ALL = Selection.Information(wdNumberOfPagesInDocument) '総ページ数
'MsgBox "ページ数 " & p_ALL & vbLf & vbLf & _
'"PDFからWordにしたことで、ページ数が変化します。 "
Call 文書末尾に追記("名前をつけて保存 " & file2 & "、ページ数 " & p_ALL & vbCrLf, file0)
'MsgBox "ファイルを閉じます。" & vbLf & _
'"(次の段階に進む前に、閉じる必要があります。) "
Documents(file2).Close '文書を閉じる
MsgBox "名前をつけて保存しました。" & vbLf & dir1 & vbLf & file2
End Sub
Sub 分割とPDF保存()
'ボタンで呼び出される。
'Private Sub CommandButton2_Click()
' Call 分割とPDF保存
'End Sub
Dim dir0 As String, dir1 As String, file1 As String, file2 As String
Dim p_ALL As Long, p1 As Long, p2 As Long, p_sep As Long
Dim i As Long
Dim txt1 As String, txt2 As String
p_sep = 1000 '何ページ単位で分割する
'マクロファイルについて
dir0 = ActiveDocument.Path '開くダイアログで最初に表示されるフォルダ
file0 = ActiveDocument.Name
'----------------------------------------
If WORDファイルをダイアログで開く(dir0) = False Then
Exit Sub '開くのをキャンセルしたら先に進まないよう停止
End If
'開いたファイルの場所と名前。後で何度か使う。
dir1 = ActiveDocument.Path
file1 = ActiveDocument.Name
If InStr(file1, ".doc") = 0 And InStr(file1, ".DOC") = 0 Then
MsgBox file1 & vbLf & "DOC / DOCX ではありません。"
Exit Sub
End If
p_ALL = Selection.Information(wdNumberOfPagesInDocument) '総ページ数
If p_ALL < 10 Then
MsgBox "ページ数が少なすぎます。ファイルを間違えているようです。"
Exit Sub
Else
'MsgBox "ページ数 " & p_ALL & vbLf & vbLf & "分割処理を開始します。 "
Call 文書末尾に追記(file1 & "、ページ数 " & p_ALL & "、分割処理を開始。", file0)
End If
'Shell "explorer " & dir0, 1 'フォルダ
For i = 1 To 30 '分割・保存を繰り返す
p1 = p_sep * (i - 1) + 1 '残すのは何ベージから
p2 = p1 + p_sep - 1 '残すのは何ベージまで
If p1 > p_ALL Then '開始が超過
Exit For '
ElseIf p2 > p_ALL Then '終了が超過
p2 = p_ALL '総ページ数を終了ページにする
End If
txt1 = p1 & "から" & p2 'Wordのページ範囲を文字列に。ファイル名に使う。
If i >= 2 Then '2回目からは、ファイルを開き直す
'If MsgBox(" i " & i & vbLf & vbLf _
'& txt1 & vbLf & _
'"ページ削除前のファイルを開き直します" & vbLf & vbLf & _
'"キャンセルすると、マクロを終了します。", _
'32 + vbOKCancel) = vbCancel Then 'OKかキャンセルかを人間が選ぶ。
' Exit Sub 'マクロ終了
'End If
Documents.Open FileName:=dir1 & "\" & file1 '開く
Documents(file1).Activate
Application.Move Left:=2, Top:=351 'ウインドウを左寄せ
Application.Resize Width:=534, Height:=333
End If
If p1 = 1 And p_ALL < p_sep Then '分割するほどのページ数がない
'MsgBox "分割不要。サイズ変更のみ実行します。"
Call 文書末尾に追記("分割不要。サイズ変更のみ実行します。", file0)
ElseIf p1 = 1 Then 'サイクルの1回目
'MsgBox p2 + 1 & "ページから末尾まで削除します"
Call 文書末尾に追記(p2 + 1 & "ページから末尾まで削除", file0)
Call 指定ページから末尾まで削除(p2 + 1)
ElseIf p1 > 1 Then 'サイクルの2回目以降
'MsgBox "先頭から " & p1 - 1 & "ページまで削除します "
Call 文書末尾に追記(p2 + 1 & "ページから末尾まで削除", file0)
Call 先頭から指定ページまで削除(p1 - 1)
'これを実行すると、例えば元々1200で、1000単位で分割しようとしている
'場合、1200-1000=残り200となるので、末尾の削除は不要となる。
p2 = p2 - (p1 - 1)
If p2 < (p_ALL - (p1 - 1)) Then '残りが多く、後ろ側の削除可能
'MsgBox p2 + 1 & "ページから末尾まで削除します"
Call 文書末尾に追記(p2 + 1 & "ページから末尾まで削除", file0)
Call 指定ページから末尾まで削除(p2 + 1)
Else 'この後ろにはもう、削除するものがない
End If
End If
'MsgBox "ページ設定A6 開始"
Call 文書末尾に追記("ページ設定A6 開始", file0)
Call ページ設定A6
file2 = Left(Replace(Replace(Replace(Replace(file1, _
".docx", ""), ".DOCX", ""), ".doc", ""), ".DOC", ""), 15) & "_" & _
txt1 & ".pdf" 'ファイル名を用意。
'長すぎるとKindleの本一覧で末尾まで見えないので、15文字で切る。
'MsgBox "PDFで保存します。 " & vbLf & file2
Call 文書末尾に追記("PDFで保存 " & file2 & vbCrLf, file0)
Call PDFで保存(dir1, file2)
Documents(file1).Close SaveChanges:=False '文書を保存しないで閉じる
Next i
MsgBox "完了"
End Sub
Sub 先頭から指定ページまで削除(ByVal myPage As Long)
Application.ScreenUpdating = False '画面の更新しない
'印刷レイアウト表示に変更します。
ActiveWindow.View.Type = wdPrintView
Selection.GoTo What:=wdGoToPage, Count:=myPage + 1
ActiveDocument.Range(0, Selection.Start).Select
Selection.Delete '削除
Application.ScreenUpdating = True '画面の更新
End Sub
Sub 指定ページから末尾まで削除(ByVal myStartP As Long)
'参考 https://www.wordvbalab.com/code/3737/
'【コード】特定ページの本文を選択するWordマクロ
Dim myEndP As Long
Dim myEnd As Long
Application.ScreenUpdating = False
'文書の末尾にカーソルを移動する
Selection.EndKey Unit:=wdStory
myEnd = Selection.End - 1
'開始ページの先頭にカーソルを移動します。
Selection.GoTo What:=wdGoToPage, _
Which:=wdGoToAbsolute, _
Count:=myStartP
'選択範囲の末尾を最終ページまで移動します。
Selection.End = myEnd
Selection.Delete '削除
Application.ScreenUpdating = True '画面の更新
End Sub
Sub ページ設定A6()
'文書全体でやろうとすると、「有効範囲を超えています」が頻発。
'その対策として、セクションごとの処理 にしている。
'注意
'環境(CPUとメモリ?)によっては、この部分でフリーズ(応答なし)
'になる。2022年3月時点、解決策が見つかっていない。
Dim mySec As Section
Application.ScreenUpdating = False '画面の更新しない
ActiveDocument.Content.Orientation = wdTextOrientationVerticalFarEast
For Each mySec In ActiveDocument.Sections
With mySec.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = MillimetersToPoints(1)
.BottomMargin = MillimetersToPoints(9) '下余白6mmでは文字が欠けるので増やす
.LeftMargin = MillimetersToPoints(1)
.RightMargin = MillimetersToPoints(1)
.Gutter = MillimetersToPoints(0)
.FooterDistance = MillimetersToPoints(0)
.PageWidth = MillimetersToPoints(100) '用紙サイズ 幅100mm
.PageHeight = MillimetersToPoints(141) '用紙サイズ 高さ141mm
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeDefault
End With
Next
Application.ScreenUpdating = True '画面の更新
End Sub
<Wordファイルにマクロを入れる方法>
スタートボタン。Win11の場合、アプリの一覧を開く。
Word をクリック。
「白紙の文書」をクリック。真っ白な新規文書の画面になる。
Alt+F11キー(キーボードのAltを押しながらF11)。
Visual Basicのウインドウが開く。
メニューの「挿入」。「標準モジュール」をクリック。
Module1 というウインドウが開く。
このウインドウの中に、ブログからプログラムをコピペする。
左側に、「標準モジュール」の上に「ThisDocument」がある
ので、ダブルクリック。
ThisDocument のウインドウが開く。
この中に、
Private Sub CommandButton1_Click()
Call PDFを読み込んでDOCXで保存
End Sub
Private Sub CommandButton2_Click()
Call 分割とPDF保存
End Sub
を貼る。
<文書上にボタンを置く方法>
Word文書のウインドウ(Visual Basicではないほう)。
上のメニューの「校閲」「表示」の右に「開発」がない場合は、
メニュー文字やリボンの上で右クリックして「リボンのユーザー設定」、「開発」にチェックを入れ、OKボタン。
「開発」のリボンの中、「コントロール」欄。
小さいボタンが並んでいる中で、黒いカバンのようなボタン
(以前のバージョンのツール)をクリック。
小さいボタン群が現れた中で、白い長方形(コマンドボタン)
をクリック。
文書上に、CommandButton1 が現れる。
メニュー(開発タブの中)の「デザインモード」をクリックして
「デザインモード」がグレーで押された状態にする。
その直下の「プロパティ」をクリック。
プロパティウインドウが現れる。
プロパティウインドウで、一番上の選択肢から
CommandButton1を選ぶ。
設定項目が10個以上ある中で「Caption」が、現在
「CommandButton1」になっているのを、
「PDFを読み込んでDOCXで保存」など、自分でわかりやすい
言葉に変える。
もう1つ、同様にボタンを作る。
(コマンドボタン。CommandButton2が現れる。
プロパティで、Captionを「分割とPDF保存」にする。)
ボタンが2つできたら、「デザインモード」をクリックして、
「デザインモード」が押されていない状態に戻す。
<名前をつけて保存>
メニューの「ファイル」、「名前を付けて保存」。
「このPC」。保存したいフォルダを選ぶ。
(加工対象のPDFを保存するのと同じ場所がよい。)
名前を付ける画面で、初期状態「文書1.docx」の文字を
全部消して、例えば「PDF分割マクロ」と入力する。
その直下、ファイルの種類は、必ず、「Wordマクロ有効文書」
を選ぶ。「保存」をクリック。
-------------------------------------------------------
訂正
2023.11.18 誤記訂正
Sub PDFを読み込んでDOCXで保存 の中の
If PDFファイルを開く(dir1) →dir0 でした。