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

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 でした。