docxをpptxにするマクロ - これおもしろい

大体フォーマットが決まっているdocxをpptxにするマクロが欲しいと言われたので備忘録。
VBA初心者なので処理に煩雑さや不具合ありそうだったらぜひ教えてください。

docxの大体のフォーマット

<Title>

1. テキスト。

2. テキスト。
改行される時もある。

3. テキスト。続く時もある。
...

必要な要件

改行でページ追加
改行文字以外は一文字にならない運用のため、一文字しかない行は処理しない
たまにShift + Enterで入るVertical Tabが入ることがあるため、vbCrに置換
docxと同名のpptxファイルを作成
上寄せの横中央揃え

実際のコード

Sub docxをpptxに変換する()
    
    ' Replace vbVerticalTab with vbCr whole document
    With ActiveDocument.Range.Find
        .text = Chr(11)
        .Replacement.text = Chr(13)
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
    
    ' Create new pptx
    Dim pptApp As PowerPoint.Application
    Dim file As Object
    Set pptApp = New PowerPoint.Application
    Set file = pptApp.Presentations.Add
    
    Dim sideMargin As Integer: sideMargin = 38
    Dim slideWidth As Integer: slideWidth = file.PageSetup.slideWidth - sideMargin * 2
    Dim slideHeight As Integer: slideHeight = file.PageSetup.slideHeight - sideMargin * 2
    
    For Each Paragraph In ActiveDocument.Paragraphs
        Dim text As String: text = Paragraph.Range.text
        
        If Len(text) <= 1 Then
            GoTo EMPTY_LINE
        End If
        
        Set Slide = file.Slides.Add(file.Slides.Count + 1, Layout:=ppLayoutBlank)
        Set textBox = Slide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=sideMargin, Top:=sideMargin, Width:=slideWidth, Height:=slideHeight)
        With textBox
            With .TextFrame
                .TextRange = text
                .TextRange.Font.Name = "Meiryo UI"
                .TextRange.Font.NameFarEast = "Meiryo UI"
                .TextRange.ParagraphFormat.Alignment = ppAlignCenter
            End With
            .TextEffect.FontSize = 40
        End With

EMPTY_LINE:
    Next Paragraph
    
    DoEvents
    
    Dim fileName As String: fileName = Split(ActiveDocument.FullName, ".")(0) & ".pptx"
    pptApp.ActivePresentation.SaveAs fileName:=fileName
  
'    pptApp.Quit
'    Set pptApp = Nothing
    
End Sub

コードの流れ

docxで、vbVerticalTabをvbCrに全置換
スライド新規作成
スライドに追加するテキストボックスの余白やサイズを指定するための前準備
docxの行取得
1. 一文字なら何もせず次の行
2. pptxに空のページ追加
3. テキストボックスを指定の位置に追加
4. テキストや指定したフォント、中央揃えを設定
5. docxの行が終わるまで上記実行
docxと同じパスに、同じ名前で保存
確認や修正のためにpptxは開いたままにする

部分ごと

コードの流れと該当のコード

1. docxで、vbVerticalTabをvbCrに全置換

    With ActiveDocument.Range.Find
        .text = Chr(11)
        .Replacement.text = Chr(13)
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With

Chr(11) = vbVerticalTab Chr(13) = vbCr

VBA Strings & Characters - Built-in Constants

2. スライド新規作成

    Dim pptApp As PowerPoint.Application
    Dim file As Object
    Set pptApp = New PowerPoint.Application
    Set file = pptApp.Presentations.Add

3. スライドに追加するテキストボックスの余白やサイズを指定するための前準備

スライドの幅高さ取得してmarginを考慮する

    Dim sideMargin As Integer: sideMargin = 38
    Dim slideWidth As Integer: slideWidth = file.PageSetup.slideWidth - sideMargin * 2
    Dim slideHeight As Integer: slideHeight = file.PageSetup.slideHeight - sideMargin * 2

4. docxの行取得

マクロ実行しようと開いているwordのparagraphを取得して文字列取得
3で用意した設定使いながら、メイリオのフォントサイズ40の横中央揃えに設定

    For Each Paragraph In ActiveDocument.Paragraphs
        Dim text As String: text = Paragraph.Range.text
        
        If Len(text) <= 1 Then
            GoTo EMPTY_LINE
        End If
        
        Set Slide = file.Slides.Add(file.Slides.Count + 1, Layout:=ppLayoutBlank)
        Set textBox = Slide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=sideMargin, Top:=sideMargin, Width:=slideWidth, Height:=slideHeight)
        With textBox
            With .TextFrame
                .TextRange = text
                .TextRange.Font.Name = "Meiryo UI"
                .TextRange.Font.NameFarEast = "Meiryo UI"
                .TextRange.ParagraphFormat.Alignment = ppAlignCenter
            End With
            .TextEffect.FontSize = 40
        End With

EMPTY_LINE:
    Next Paragraph

For文のcontinueを途中で呼びたい時はGoToを使うのでよいのかな？もっとよい方法あるの？
この後にDoEvents設置してたけど、これ効果あるの？確認しないと

5. docxと同じパスに、同じ名前で保存

フルパス取得した上で拡張子だけ変える

    Dim fileName As String: fileName = Split(ActiveDocument.FullName, ".")(0) & ".pptx"
    pptApp.ActivePresentation.SaveAs fileName:=fileName

6. 確認や修正のためにpptxは開いたままにする

保存は5でしているので、閉じたい場合はコメントアウトを外す

'    pptApp.Quit
'    Set pptApp = Nothing

雑感

VSCodeでVBAの環境作ろうと思ったけど、text-scripting-vbaをマクロにコピーして実行したらエラー出た。まあいいかと思って大人しくVBEで実装。また触ることがあったら今度こそ整えよう...。（自分のPCでないけども。Office365普段使わないから入ってない。）
このシンプルな処理を実装するのに半日以上掛かった(´・ω・｀)以前2つ開いているdocxの行を交互に抽出して新規作成したdocxの1ページに納めていく（最終的にPDFに保存したいという要望）マクロを作ったけど、全然覚えてなかった。人は忘却の生き物ですね。
疲れたけど、普段書かない言語書くのも面白いなー。関数への切り出ししないなら、せめてコードにちゃんとコメント入れないと、数日後の自分が分からなくなりそうだなぁ。