修正対比資料をPowerPointで作りたい

メモ

A4タテ用紙とA3ヨコ用紙のみで構成された書類があったとする。
この書類の修正対比資料の下地をPowerPoint 2013で作成したい。
作成方法としてはスライドのサイズをA3ヨコにして、書類がA4タテ用紙の場合はスライドマスターの左右に配置、書類がA3ヨコの場合は全面に配置するだけ。

画像貼り付け後

あらかじめ下図のように、元の書類の各ページから画像ファイルを作成しておく。

背景画像選択

ページの画像ファイルを、スライドマスターのレイアウトに貼り付ける。
このレイアウトを各スライドのレイアウトとして適用し、修正対比資料の下地とする。

pptxファイルを新規作成するたびに既定図形やオプションを設定し直すのも手間なので、以下の使い捨てマクロでは「背景画像の貼り付け先pptxファイル」の設定をそのまま利用しています。
細かい設定を流用したいだけなので「背景画像の貼り付け先pptxファイル」の既存スライドやスライドマスター等をマクロで削除しています。

使い捨てマクロ

' PowerPoint 2013
' 標準モジュール

Option Explicit


Private Function MillimetersToPoints(ByVal millimeters As Double) As Double
    ' 1[in] = 25.4[mm]
    ' 1[pt] = 1[in] / 72 = (25.4/72)[mm]
    MillimetersToPoints = millimeters * 72 / 25.4
End Function


Public Sub Main()
    Dim prActive As PowerPoint.Presentation
    Dim prTemplate As PowerPoint.Presentation
    Dim sld As PowerPoint.Slide
    Dim shp As PowerPoint.Shape
    Dim fd As Office.FileDialog
    Dim filePathsBgImg As VBA.Collection
    Dim filePathTemplatePptx As String
    Dim i As Long, k As Long

    Set prActive = PowerPoint.Application.ActivePresentation

    Set filePathsBgImg = New VBA.Collection

    Set fd = prActive.Application.FileDialog( _
                Type:=Office.MsoFileDialogType.msoFileDialogFilePicker _
                )
    fd.Title = "背景画像ファイル"
    fd.AllowMultiSelect = True
    fd.Filters.Clear
    fd.Filters.Add _
        Description:="画像", _
        Extensions:="*.bmp; *.png; *.jpg; *.jpeg", _
        Position:=1

    If fd.Show = -1 Then
        For i = 1 To fd.SelectedItems.Count Step 1
            filePathsBgImg.Add fd.SelectedItems.Item(i)
        Next i
    Else
        VBA.Interaction.MsgBox _
            Prompt:= _
            "背景画像ファイルが未選択です。" & _
            VBA.Constants.vbCrLf & _
            "マクロを終了します。"
        Exit Sub
    End If

    fd.Title = "背景画像の貼り付け先pptxファイル"
    fd.AllowMultiSelect = False
    fd.Filters.Clear
    fd.Filters.Add _
        Description:="pptx", _
        Extensions:="*.pptx", _
        Position:=1

    If fd.Show = -1 Then
        filePathTemplatePptx = fd.SelectedItems.Item(1)
    Else
        VBA.Interaction.MsgBox _
            Prompt:= _
            "背景画像の貼り付け先pptxファイルが未選択です。" & _
            VBA.Constants.vbCrLf & _
            "マクロを終了します。"
        Exit Sub
    End If

    ' 背景画像の貼付け先pptxファイルを開く
    Set prTemplate = PowerPoint.Presentations.Open( _
                        FileName:=filePathTemplatePptx _
                        )

    ' 用紙サイズの設定
    With prTemplate.PageSetup
        .SlideWidth = MillimetersToPoints(420)
        .SlideHeight = MillimetersToPoints(297)
    End With

    ' スライドを全て削除
    With prTemplate.Slides
        For k = .Count To 1 Step -1
            .Item(k).Delete
        Next k
    End With

    ' セクションを全て削除
    With prTemplate.SectionProperties
        For k = .Count To 1 Step -1
            .Delete sectionIndex:=k, deleteSlides:=False
        Next k
    End With

    ' ノートマスターに含まれる図形を全て削除
    With prTemplate.NotesMaster.Shapes
        For k = .Count To 1 Step -1
            .Item(k).Delete
        Next k
    End With

    ' 配布資料マスターに含まれる図形を全て削除
    With prTemplate.HandoutMaster.Shapes
        For k = .Count To 1 Step -1
            .Item(k).Delete
        Next k
    End With

    ' スライドマスター(2番目以降)を削除
    With prTemplate.Designs
        For k = .Count To 2 Step -1
            .Item(k).Delete
        Next k
    End With

    ' スライドマスター(1番目)の図形を全て削除
    With prTemplate.Designs.Item(1).SlideMaster.Shapes
        For k = .Count To 1 Step -1
            .Item(k).Delete
        Next k
    End With

    ' スライドマスター(1番目)の背景書式を設定
    With prTemplate.Designs.Item(1).SlideMaster
        .Background.Fill.Solid
        .Background.Fill.ForeColor.RGB = _
            VBA.Information.RGB(Red:=255, Green:=255, Blue:=255)
        .Background.Fill.Transparency = 0
    End With

    ' スライドマスター(1番目)内にあるレイアウト(2番目以降)を削除。
    ' スライドで使用中のレイアウトは削除できない。
    ' レイアウトが削除できない場合、
    ' 手動で既存スライドに適用中のレイアウトを変更するなど行う。
    With prTemplate.Designs.Item(1).SlideMaster.CustomLayouts
        For k = .Count To 2 Step -1
            .Item(k).Delete
        Next k
    End With

    ' スライドマスター(1番目)の名前を設定する
    prTemplate.Designs.Item(1).Name = "スライドマスター1"


    For i = 1 To filePathsBgImg.Count Step 1

        If filePathsBgImg.Item(i) = VBA.Constants.vbNullString Then
            Exit For
        End If

        If i >= 2 Then
            prTemplate.Designs.Item(1).SlideMaster.CustomLayouts.Add Index:=i
        End If

        ' スライドマスター(1番目)内にあるレイアウト(i番目)の
        ' 背景書式を設定
        With prTemplate.Designs.Item(1).SlideMaster.CustomLayouts.Item(i)
            .Background.Fill.Solid
            .Background.Fill.ForeColor.RGB = _
                VBA.Information.RGB(Red:=255, Green:=255, Blue:=255)
            .Background.Fill.Transparency = 0
            .FollowMasterBackground = Office.MsoTriState.msoFalse
            .DisplayMasterShapes = Office.MsoTriState.msoFalse
        End With

        ' スライドマスター(1番目)内にあるレイアウト(i番目)の
        ' 図形を全て削除した後に、画像を挿入する
        With prTemplate.Designs.Item(1).SlideMaster.CustomLayouts.Item(i).Shapes
            For k = .Count To 1 Step -1
                .Item(k).Delete
            Next k

            Set shp = .AddPicture( _
                        FileName:=filePathsBgImg(i), _
                        LinkToFile:=Office.MsoTriState.msoFalse, _
                        SaveWithDocument:=Office.MsoTriState.msoTrue, _
                        Left:=MillimetersToPoints(0), _
                        Top:=MillimetersToPoints(0) _
                        )

            If shp.Height >= shp.Width Then
                ' 画像が縦長の場合はA4タテ用紙と見なして
                ' スライド(A3用紙)の左右に配置する
                shp.Height = MillimetersToPoints(297)
                shp.Width = MillimetersToPoints(210)
                shp.ZOrder Office.MsoZOrderCmd.msoSendBackward
                shp.Name = "図" & Format(i, "000") & "-A4左"

                Set shp = .AddPicture( _
                                FileName:=filePathsBgImg(i), _
                                LinkToFile:=Office.MsoTriState.msoFalse, _
                                SaveWithDocument:=Office.MsoTriState.msoTrue, _
                                Left:=MillimetersToPoints(210), _
                                Top:=MillimetersToPoints(0), _
                                Width:=MillimetersToPoints(210), _
                                Height:=MillimetersToPoints(297) _
                                )
                shp.ZOrder Office.MsoZOrderCmd.msoSendBackward
                shp.Name = "図" & Format(i, "000") & "-A4右"
                
                Set shp = .AddLine( _
                                MillimetersToPoints(210), MillimetersToPoints(0), _
                                MillimetersToPoints(210), MillimetersToPoints(297) _
                                )
                shp.Line.Weight = 1.5
                shp.Line.ForeColor.RGB = VBA.Information.RGB(0, 0, 0)
                shp.Line.DashStyle = Office.MsoLineDashStyle.msoLineSolid
                shp.Line.BeginArrowheadStyle = Office.MsoArrowheadStyle.msoArrowheadNone
                shp.Line.EndArrowheadStyle = Office.MsoArrowheadStyle.msoArrowheadNone
                shp.ZOrder Office.MsoZOrderCmd.msoBringToFront
                shp.Name = "図" & Format(i, "000") & "-A4区切り線"
            Else
                ' 画像が横長の場合はA3ヨコ用紙と見なして
                ' スライド(A3用紙)の全面に配置する
                shp.Height = MillimetersToPoints(297)
                shp.Width = MillimetersToPoints(420)
                shp.ZOrder Office.MsoZOrderCmd.msoSendBackward
                shp.Name = "図" & Format(i, "000") & "-A3"
            End If

            prTemplate.Designs.Item(1).SlideMaster.CustomLayouts.Item(i).Name = _
                "レイアウト1-" & Format(i, "000")

        End With

        ' スライド(i枚目)を追加
        ' スライドのレイアウトをスライドマスター(1番目)のレイアウト(i番目)に設定する
        Set sld = prTemplate.Slides.AddSlide( _
                        Index:=i, _
                        pCustomLayout:=prTemplate.Designs.Item(1).SlideMaster.CustomLayouts.Item(i) _
                        )
    Next i

End Sub