Wordマクロで、PDFをA6サイズに変換する

◆使用目的・開発理由
　ネットから無料ダウンロードできるPDF形式の小説は、
　PC画面で読むのには適したサイズですが、Kindleでは
　字が小さすぎて読めません。
　Wordで用紙サイズを変更すればいいのですが、
　ファイルがあまり大きいと、私のKindle（2015年購入）では
　途中でフリーズすることがあります。
　そこで、サイズ変更だけでなく、分割もするのですが、
　何度も繰り返し作業をするのが面倒なので、
　「マクロで自動化しよう」と思いました。

---

◆動作順序
1．マクロ「PDFを読み込んでDOCXで保存」を実行すると、
　どのPDFを開くか、と聞いてきます。
　ファイルを選択すると、PDFをWordで開いて、
　拡張子.docx で保存します。
2．マクロ「分割とPDF保存」を実行すると、
　どのWord文書を開くか、と聞いてきます。
　ファイルを選択すると、下記の繰り返し作業をします。
　　・Word文書を開く。
　　・不要なページを削除。

　　　（残す位置は、毎回ずらしていく。）
　　・用紙サイズを変更。

　　　（この加工で、ページ数が増えます。）
　　・PDFで保存。
　　・Word文書を保存しないで閉じる。

◆準備
1．マクロを、標準モジュールに貼り付けます。
2．文書に、コマンドボタンを2つ置きます。
（ボタンを作ってマクロを紐付けする方法は、

　説明を省略します。）

◆準備2 カスタマイズ
1．マクロ「Sub 分割とPDF保存()」の中の
　「p_sep = 1000」を、変更したい場合は変更します。
2．マクロ「Sub ページ設定A6()」は、
　用紙をA6サイズぐらい設定するようになっているので、
　変更したい場合は数字を調整します。
3．マクロの途中に MsgBoxが何度も入っていて、
処理中にOKボタンをクリックしなくてはなりません。
安定して動作するのを確認できたら、

MsgBoxを無効化すればよいと思います。

◆問題点　　（不完全での紹介になりすみません。）
1．PCによっては、応答なし になり動かない。
　私が試したPCは2台だけですが、スペックが低い方のPCは
　「Sub ページ設定A6()」で停止してしまいました。
　どう変更すればよいのか、色々試したのですが、

　わかりませんでした。
2．処理に時間がかかる。
　Wordマクロの素人が作成したので、
　「ページ範囲を取り出して別ファイルにする」
　というスマートな方法ではなく
　「大きいファイルを開いて不要なページを削除
　を、何度も繰り返す」
　という、時間のかかる処理になっています。
3．変換後のPDFの、再現度が不完全。
　・小説のページ番号が文章中につながっていることがある。
　・カギカッコの位置がずれていることがある。
　など、サイズ変換で一部おかしくなることがあります。

◆開発、動作確認の環境
環境1.動作したパソコン
　ハード：マウスコンピュータ製デスクトップPC 2019年購入
　　　CPU Core i7-9700K　4.9GHz/8コア、メモリ 32GB
　OS:  Win10
　Word：Microsoft Office Personal 2019　の

　　　　　Word バージョン2202
　PDFソフト：Adobe Acrobat X Standard
環境2．「応答なし」になり動作しないパソコン
　ハード：NEC製ノートPC　2018年
　　　CPU  Celeron 3855U（1.60GHz 2コア）、メモリ 16GB
　OS:  Win10
　Word：Office Professional Plus 2019。
  Acrobatなし｡ (Acrobatの有無が影響するのか不明) 

---

マクロ

Sub PDFを読み込んでDOCXで保存()
'ボタンで呼び出される。
'Private Sub CommandButton1_Click()
'    Call PDFを読み込んでDOCXで保存
'End Sub
    Dim dir1 As String, file1 As String, file2 As String
    Dim p_ALL As Long
    
    'マクロファイルについて
    dir1 = ActiveDocument.Path '開くダイアログで最初に表示されるフォルダ
    file1 = ActiveDocument.Name
    
    If PDFファイルを開く(dir1) = 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
    
    
    '保存予定の名前を作成
    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にしたことで、ページ数が変化します。 "
    
    MsgBox "ファイルを閉じます。" & vbLf & _
    "（次の段階に進む前に、閉じる必要があります。） "
    Documents(file2).Close          '文書を閉じる
    

End Sub


Sub 分割とPDF保存()
'ボタンで呼び出される。
'Private Sub CommandButton2_Click()
'    Call 分割とPDF保存
'End Sub

    Dim 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    '何ページ単位で分割する

    'マクロファイルについて
    dir1 = ActiveDocument.Path  '開くダイアログで最初に表示されるフォルダ
    
    If WORDファイルをダイアログで開く(dir1) = 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 & "分割処理を開始します。 "
    End If
    
    
    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
        End If
         
    
        If p1 = 1 And p_ALL < p_sep Then     '分割するほどのページ数がない
            MsgBox "分割不要。サイズ変更のみ実行します。"
            
        ElseIf p1 = 1 Then      'サイクルの1回目
            MsgBox p2 + 1 & "ページから末尾まで削除します"
            
            Call 指定ページから末尾まで削除(p2 + 1)
        
        ElseIf p1 > 1 Then      'サイクルの2回目以降
            MsgBox "先頭から " & p1 - 1 & "ページまで削除します "
            
            Call 先頭から指定ページまで削除(p1 - 1)
            
            'これを実行すると、例えば元々1200で、1000単位で分割しようとしている
            '場合、1200-1000＝残り200となるので、末尾の削除は不要となる。
        
            p2 = p2 - (p1 - 1)
            
            If p2 < (p_ALL - (p1 - 1)) Then  '残りが多く、後ろ側の削除可能
                MsgBox p2 + 1 & "ページから末尾まで削除します"
                'txt2 = txt2 & vbLf & Format(Time, "(hh:mm)") & p2 + 1 & "ページから末尾まで削除"
                Call 指定ページから末尾まで削除(p2 + 1)
            Else   'この後ろにはもう、削除するものがない
                
            End If
            
       
        End If
        
        MsgBox "ページ設定A6 開始"
        Call ページ設定A6
         
        file2 = Replace(Replace(Replace(Replace(file1, _
        ".docx", ""), ".DOCX", ""), ".doc", ""), ".DOC", "") & "_" & _
        txt1 & ".pdf"       'ファイル名を用意
        
        MsgBox "PDFで保存します。 " & vbLf & file2
        
        Call PDFで保存(dir1, file2)
     
        Documents(file1).Close SaveChanges:=False     '文書を保存しないで閉じる
    
    Next i

    MsgBox "完了"

End Sub


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 先頭から指定ページまで削除(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(10)  '下余白10mm
        .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
 

---

◆変更メモ

・22年7月 。Sub ページ設定A6 の
    .BottomMargin = MillimetersToPoints(6)  '下余白6mm
    の部分を
    .BottomMargin = MillimetersToPoints(10)  '下余白10mm
    に変更。Kindle下端の％表示のせいで文字が欠けるのを防ぐため。

◆エラー対応　23年1月追記。

docxファイルを分割・サイズ変更処理するとき、
「オブジェクトによりレイアウト枠内の段落が参照されているためメソッドまたはプロパティが使用できません」というエラーが出た場合の対処方法は下記。

（マクロで自動回避する方法がわからないので、手作業で加工します。）
docxの最初のほうはA6サイズに加工されて、途中から未処理になっている。

処理済みと未処理の境界位置を探す。

その場所に、小さい表があって障害になっている。

表の付近の文章を覚える。（例、「終わったよ」というセリフ。）

docxを保存しないで閉じる（全部未加工の状態にしたいので）。

docxを開く。

Ctrl+F 検索で、先ほど調べた文章（例、「終わったよ」）を検索。

表をクリック。

表の左上の四角いマークで右クリック、「表の削除」。
上書き保存して、閉じる。

マクロ「分割とPDF保存」実行。

◆23年3月追記。

　改良版を公開しました。Wordファイルの作り方も記載しました。Wordマクロで、PDFをA6サイズに変換する 改良版