VBA PowerPoint文書Nin1

PowerPointには「スライド一覧」の表示機能があり、ページ並びを編集したり、スライド全体の流れを把握したりする時に活用されると思います。

その「スライド一覧」イメージの文書ファイルを作成するツールを作りました。スライドイメージを縮小して、複数ページを１枚のスライドにN in 1形式で貼り付けたスライドを作成します。スライドを貼り付ける際のパラメータを、Excelシート上の表で指定できるよう、ExcelにVBAプログラムを組み込んだものとしています。

ツールファイル添付

VBAプログラムを組み込んだExcelのツールファイルを添付します。

PPT文書Nin1.xlsm

28.8 KB

ファイルダウンロードについて

ダウンロード

ツールの使い方

Excelのツールファイルを開いて、「貼り付けるスライドの設定」や「貼り付け先スライドのページ設定」の表内容を設定して、「PPT文書 N in 1」ボタンを押します。

ファイルダイアログが開くので、対象のPowerPoint文書ファイルを選択して、「OK」ボタンを押します。Ctrlキーを押しながらファイル名をクリックすることで、複数ファイルを選択可能です。

スライドイメージをN in 1形式で貼り付けたPowerPoint文書が作成され、対象ファイルと同じフォルダ内に保存されます。

「貼り付けるスライドの設定」表の項目説明です。
・横枚数：横方向に貼付けるスライドイメージの最大枚数
・縦枚数：縦方向に貼付けるスライドイメージの最大枚数
・貼付け方向：貼付ける順番を「横方向」か「縦方向」で指定

「貼り付け先スライドのページ設定」表の項目説明です。
・スライドサイズ：標準(4:3)、ワイド画面(16:9)、A4のいずれかで指定
・スライド向き：「横向き」か「縦向き」で指定
・上/下/左/右余白：スライド端と貼付け領域との余白をcm単位で指定
・最小スライド間：スライド間の最小間隔を[cm単位]で指定

プログラムの解説

プログラムの主な内容を説明します。

PARAMETER_TYPEは、スライドイメージを貼り付ける際の様々なパラメータを保持するユーザー定義型です。

Private Type PARAMETER_TYPE
    HNum As Integer             '横枚数 (Horizontal Number)
    VNum As Integer             '縦枚数 (Vertical Number)
    Direction As String         '貼付け方向
    SlideSize As String         'スライドサイズ
    SlideOrientation As String  'スライド向き
    MarginTop As Single         '上余白
    MarginBottom As Single      '下余白
    MarginLeft As Single        '左余白
    MarginRight As Single       '右余白
    MinPad As Single            '最小スライド間 (Minimum Padding)
    
    MaxSlides As Integer        '1頁あたり最大スライド数
    CWidth As Single            '圧縮後のスライド幅 (Compress Width)
    CHeight As Single           '圧縮後のスライド高さ (Compress Height)
    HPad As Single              'スライド横間隔 (Horizontal Padding)
    VPad As Single              'スライド縦間隔 (Vertical Padding)
End Type
 
Private Pa As PARAMETER_TYPE

buttonPowerPointNin1_Clickは、「PPT文書 N in 1」ボタンのクリックで呼び出されるメイン処理です。PowerPointアプリケーションを起動して、対象の文書ファイルを開くとともに、貼付け先の文書を追加します。貼付け先の文書のページ設定、各種パラメータの準備を行った後、N in 1の貼付け文書を作成します。

Private Sub buttonPowerPointNin1_Click()
    Call StatusBar("準備中...")
    Call SetParameter
    
    Dim app As Object: Set app = CreateObject("PowerPoint.Application")
    
    Dim sFileName As Variant
    For Each sFileName In DialogFileName("PowerPoint", "*.ppt*")
        
        Dim src As Object: Set src = app.Presentations.Open(sFileName)
        Dim dst As Object: Set dst = app.Presentations.Add
        
        Call SetupPage(dst)
        
        Call CalcParameter(src, dst)
        
        Call CreatePPtNin1(src, dst)
        
        dst.SaveAs Filename:=dstPath(CStr(sFileName), "pptx")
        dst.Close
        src.Close
    Next sFileName
    
    app.Quit
    Call StatusBar("完了!")
End Sub

CalcParameterは、各種パラメータを算出する処理です。「1頁あたり最大スライド数」や「圧縮後のスライド幅・高さ」「スライド横・縦間隔」を求めます。

Private Sub CalcParameter(src As Object, dst As Object)
    Pa.MaxSlides = Pa.HNum * Pa.VNum
    
    Dim nWidth As Single    '貼付領域の幅
    Dim nHeight As Single   '貼付領域の高さ
    nWidth = dst.PageSetup.SlideWidth - Pa.MarginLeft - Pa.MarginRight
    nHeight = dst.PageSetup.SlideHeight - Pa.MarginTop - Pa.MarginBottom
    
    Pa.CWidth = (nWidth - Pa.MinPad * (Pa.HNum - 1)) / Pa.HNum
    Pa.CHeight = (nHeight - Pa.MinPad * (Pa.VNum - 1)) / Pa.VNum
    
    With src.PageSetup
        If (Pa.CHeight / Pa.CWidth) < (.SlideHeight / .SlideWidth) Then
            Pa.CWidth = Pa.CHeight * (.SlideWidth / .SlideHeight)
            Pa.VPad = Pa.MinPad
            
            If Pa.HNum = 1 Then
                Pa.HPad = 0
            Else
                Pa.HPad = (nWidth - Pa.CWidth * Pa.HNum) / (Pa.HNum - 1)
            End If
        Else
            Pa.CHeight = Pa.CWidth * (.SlideHeight / .SlideWidth)
            Pa.HPad = Pa.MinPad
            
            If Pa.VNum = 1 Then
                Pa.VPad = 0
            Else
                Pa.VPad = (nHeight - Pa.CHeight * Pa.VNum) / (Pa.VNum - 1)
            End If
        End If
    End With
End Sub

CreatePPtNin1は、N in 1のスライドを作成する処理です。ページ番号から貼付け位置を求めてスライドイメージを貼付けた後、貼付けたスライドイメージのサイズ、位置を調整します。

Private Sub CreatePPtNin1(src As Object, dst As Object)
    ：
    Dim srcPage As Integer
    For srcPage = 1 To src.Slides.Count
        Call StatusBar(src.Name & " - p." & srcPage)
        
        Dim HPos As Integer     '左起点の横貼付位置(0,1,2...)
        Dim VPos As Integer     '上起点の縦貼付位置(0,1,2...)
        If Pa.Direction = "横方向" Then
            HPos = (srcPage - 1) Mod Pa.HNum
            VPos = Int((srcPage - 1) / Pa.HNum) Mod Pa.VNum
        Else
            HPos = Int((srcPage - 1) / Pa.VNum) Mod Pa.HNum
            VPos = (srcPage - 1) Mod Pa.VNum
        End If
        
        dstPage = Int((srcPage - 1) / Pa.MaxSlides) + 1
        
        Dim oSlideImage As Object
        Set oSlideImage = PasteSlide(src.Slides(srcPage), dst.Slides(dstPage))
        
        With oSlideImage
            .LockAspectRatio = True
            .Width = Pa.CWidth
            
            .Top = Pa.MarginTop + (VPos * (Pa.CHeight + Pa.VPad))
            .Left = Pa.MarginLeft + (HPos * (Pa.CWidth + Pa.HPad))
            
            ：
        End With
    Next srcPage
End Sub

PasteSlideは、スライドイメージをクリップボードを経由して貼り付けます。クリップボードへの格納が間に合わず貼付けエラーが発生した場合は、3回までリトライします。

Private Function PasteSlide(srcSlide As Object, dstSlide As Object) As Object
    Const ppPastePNG = 6    'PNG形式貼付け
    
    Set PasteSlide = Nothing
    
    srcSlide.Copy
    
    On Error Resume Next
    Dim i As Integer
    For i = 0 To 3          '貼付けエラー時は3回までリトライ
        DoEvents
        Set PasteSlide = dstSlide.Shapes.PasteSpecial(ppPastePNG)
        If Not (PasteSlide Is Nothing) Then Exit Function
    Next i
End Function

さいごに

PowerPoint文書の概要資料などを作成したりする際に活用できるかと思います。
VBAプログラム全体を閲覧されたい方は以下にパスワードを示します。