PageSetup SlideOrientation パワポ マクロ スライドの向き 縦・横の設定

要約: パワポのマクロでエクセルのデータからスライドを自動作成する際に、スライドの方向が違うと画像として貼り付けられる問題に対処する方法を紹介する記事。PageSetup.SlideOrientationプロパティを使って、新規スライドとテンプレートの方向を合わせることで解決できる。

キーワード: パワポ,マクロ,スライド方向,PageSetup.SlideOrientation,画像貼り付け

YouTubeのタイトル案:

• パワポマクロでスライド方向を自動調整する方法
• スライド方向が違うと画像になる？パワポマクロのデバッグ調整テクニック
• PageSetup.SlideOrientationでパワポマクロの不具合を解消する

www.youtube.com
https://www.youtube.com/watch?v=0esUynLKtGo
目次:
00:00 あいさつ、不具合内容と修正依頼
00:24 1.縦のテンプレ スライドを用意してやってみた
02:16 2.スライドの方向をそろえてから、コピーする
03:51 実行結果
06:57 3.おわりのあいさつ

前回の処理:差し込み印刷っぽい処理 エクセルのデータからパワポのスライドを自動作成する Excel To PowerPoint
https://www.youtube.com/watch?v=tprejIA-Q-M&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&index=1&t=1299s
上記処理について下記の質問をいただく
バグ、不具合の連絡をいただく。

＞①PowerPointのテンプレートが実は縦シートになっており
＞マクロ実行すると新規シートが横なため
＞テキストボックスではなく画像として貼付展開されてしまいます。
＞テンプレートにそのまま貼付け使用しても
＞最終的には別名で保存（以下③の対応）したいため、
＞新規開かなくても問題ありません。

1.縦のテンプレ スライドを用意してやってみた

画像にはならなかったけど、
あきらかに、おかしかったです。

原因は、
新規作成でデフォルトが横スライド、
そのスライドに貼り付け。

サイズがおかしくなったり、
環境によっては、親切に画像として貼り付いたりすると思います。
※質問者さんと状況が違うのは、デフォルトの貼り付け形式が違うからかなぁ？
　少し、気になるけど。

2.スライドの方向をそろえてから、コピーする

原因は、スライドのサイズなので、
スライドの方向をそろえてから、コピーする。

スライドの方向は、
過去記事の
https://ken3memo.hatenablog.com/entry/2022/05/20/073000

'新規プレゼンファイルの追加 https://www.youtube.com/watch?v=5ZQMhv0s9qs
oPP.Presentations.Add WithWindow:=msoTrue '新規プレゼンの追加

'縦のスライドにする https://www.youtube.com/watch?v=pcjlxaZWgnU
oPP.ActivePresentation.PageSetup.SlideOrientation = 2 '2:msoOrientationVertical

を参考にして、
PageSetup.SlideOrientation = 2 '2:msoOrientationVertical
で、タテに。

おっと、タテ固定にすると、今度は、横の時に・・・
テンプレの
PageSetup.SlideOrientation
を
そのまま、新規にセットする方がいいですね。

    '2023/06/25 追加 スライドの方向をそろえる PageSetup.SlideOrientation
    pp新規.PageSetup.SlideOrientation = ppひな型.PageSetup.SlideOrientation
    '↑新規とひな型のページ方向をそろえる。※A4とA3とかサイズ違いは未対応

を組み入れて、テストしてみる。

'新規プレゼンを作成後、
'PageSetup.SlideOrientation を テンプレと合わせる
'スライドの方向をそろえないとね
'※スライドの方向だけでいいのか？将来的にA3とかテンプレで出てきたら・・・
Sub デバッグ20230625_01B新規プレゼンの方向をひな型と合わせる()

    'PowerPointアプリの起動
    Dim ppApp As Object   'PowerPoint.Application
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True '可視にする
    DoEvents

    'ひな型ファイルを開く
    Dim strPPFName As String
    strPPFName = "D:\テンプレート\テンプレ0625縦.pptx"  '※固定でフルパス
    '↑デバッグで用意した縦スライドをテンプレ元にする

    '開く、コピー元を変数に入れる
    Dim ppひな型 As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppひな型 = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppひな型 = ppApp.Presentations.Open(strPPFName) 'ファイル名を指定して開く
    DoEvents
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppひな型 Is Nothing Then '↑上で開けたか？
        'openエラーの時、開けなかったことを知らせる
        MsgBox strPPFName & "が開けません確認してください", vbExclamation
        Exit Sub  'んっ？空のppAppが残るか、これだと・・・
    End If

    
    '新規の枠、新規プレゼンの作成
    Dim pp新規 As Object  'As PowerPoint.Presentation
    Set pp新規 = ppApp.Presentations.Add(WithWindow:=msoTrue) '新規追加
    
    '2023/06/25 追加 スライドの方向をそろえる PageSetup.SlideOrientation
    pp新規.PageSetup.SlideOrientation = ppひな型.PageSetup.SlideOrientation
    '↑新規とひな型のページ方向をそろえる。※A4とA3とかサイズ違いは未対応

    Dim ppSlide As Object  'As PowerPoint.Slide
    
    Dim y As Long  '行カウンタ
    Dim PageCODE  As Variant  'この値がキーが変更されたら改ページする
    
    Dim x As Long  '4.2追加 列のカウンター
    Dim cnt明細行   As Long   '明細行1～5をカウントする
    Dim str転記列名 As String '日付1～5,や,場所1～5 などppの転記先テキストボックス名
    Dim ppShape     As Object 'As PowerPoint.Shape ↑の名前のシェイプを代入

    'A列が存在する間ループする
    y = 2    'A2から始めたいので 2
    PageCODE = "初回に改ページしてねの意味を込めて長文"  '本当はPageCODE ="" などで初期化
    While Len(Trim(Cells(y, "A"))) > 0  'A列のデータが存在する間、ループする
        '改ページチェック CODEが変わったか？チェックする
        If PageCODE <> Cells(y, "A") Then '保存されている値と比べ 変更されていたら
            PageCODE = Cells(y, "A")  '値を保存する※このキー値の間処理をするため保存
            'キー、基準が変わったので、改ページ処理(ひな型からコピーして増やす)
            ppひな型.Slides.Range(1).Copy  '単純に1ページ目をコピー
            DoEvents
            '新規に貼り付ける。新スライドページの作成
            Set ppSlide = pp新規.Slides.Paste   'ひな型を新プレゼンの最後に追加貼り付け
            '↑ペーストついでに、変数にセットしておくと、便利ですよ
            DoEvents
            'ページが変わったので、タイトルをセット
            ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE  'キーをタイトルにセット
            DoEvents
            '4.3 サンプル文字を消す cnt明細行 ← 変数使いまわしはバグの元だけど
            For cnt明細行 = 1 To 5  '列見出し+1～5の項目をクリアする
                '列のループですよ、y行内で横方向に進むぞ
                For x = 1 To 99  '99列までループにして途中でExitするループ
                    str転記列名 = Trim("" & Cells(1, x)) '1行目の見出し x列で項目名を取得
                    If Len(str転記列名) = 0 Then Exit For '転記項目が無くなったら抜ける
                    
                    '転送先の項目名は、名前1～5なので、
                    str転記列名 = str転記列名 & cnt明細行  'で単純に作る。※DATA1とDATA11,15問題は考えない
                    
                    'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
                    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
                    Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
                    Set ppShape = ppSlide.Shapes(str転記列名) 'セットするオブジェクト
                    ppShape.TextFrame.TextRange.Text = " " '4.3 スペースを1つセットでクリア
                    On Error GoTo 0  '忘れないで戻すぞ
                Next x
            Next cnt明細行
            
            '4.2 ページが変わったら、明細行も1からなので
            cnt明細行 = 1   'ppセットへ名前1にリセット 4.3ホント、ここ、忘れないでね・・・
        End If
        
        '4.2 明細のセット ↑で、作られた枠、ページにセットする
        '列のループですよ、y行内で横方向に進むぞ
        For x = 1 To 99  '99列までループにして途中でExitするループ
            str転記列名 = Trim("" & Cells(1, x)) '1行目の見出し x列で項目名を取得
            If Len(str転記列名) = 0 Then Exit For '転記項目が無くなったら抜ける
            
            '転送先の項目名は、名前1～5なので、
            str転記列名 = str転記列名 & cnt明細行  'で単純に作る。※DATA1とDATA11,15問題は考えない
            
            'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
            On Error Resume Next  'エラーが発生しても強引に次の命令に行け
            Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
            Set ppShape = ppSlide.Shapes(str転記列名) 'セットするオブジェクト
            ppShape.TextFrame.TextRange.Text = Cells(y, x).Text 'Excelから文字列を代入
            On Error GoTo 0  '忘れないで戻すぞ
        Next x
        
        cnt明細行 = cnt明細行 + 1  '4.2 明細のセット位置も次にするよ
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
    Wend
    
    'ひな型は閉じる、新規プレゼンは開いたまま
    ppひな型.Close
    DoEvents
    Set ppひな型 = Nothing
    
    MsgBox "処理終了、パワポで確認してください"

End Sub

3.おわりのあいさつ

とりあえず、方向だけ、
PageSetup.SlideOrientation
で合わせてみました。

次のバグ、不具合の修正を開始しないとなぁ。

読者の心の声:えっ、まだあるの？