Excel 画像Fileの挿入はShapes.AddPictureを使う ActiveSheet.Pictures.Insertがリンク貼り付けで失敗した話

パワポのスライドイメージをjpg画像にしてエクセルシート単位で保存したい

PowerPoint各スライドをjpgにする

スライドをシート別に貼り付ける

1.キッカケ

下記の質問をいただく

Ken3様

おはようございます。

パワーポイントのスライド画像をエクセルシートへ1枚1スライドで貼り付けるマクロの作成を依頼したい

具体的には、以下のような機能を持つマクロを作成していただきたいです。
・パワーポイントファイルを選択すると、そのファイル内の全てのスライド画像をエクセルシートにコピーする
・1枚のスライド画像は1枚のエクセルシートに貼り付けられる
・エクセルシートの名前はスライドの番号と同じになる

このようなマクロを作成していただくことは可能でしょうか？

もし可能でしたら、お忙しいところ恐れ入りますが、よろしくお願いいたします。

---

youtube.com
https://youtube.com/live/ingF9kqRRho
目次
00:00 あいさつ
00:33 1.キッカケの質問を紹介する やりたいこと
01:40 2.失敗パターンと成功パターンを先に見せる
02:32 2.1 失敗例 マクロ記録のActiveSheet.Pictures.Insertをそのまま使うと
06:25 2.2 成功例 Shapes.AddPictureを使う
10:27 3.1 パワポのスライドからjpgを作成するのは簡単で Slides(p).Export "ファイル名", "jpg"
13:18 3.2 マクロ記録でjpgの挿入を探る よく確認しないで使用した私のミス
20:35 3.3 Shapes.AddPictureを使い リンクをFalseにしてjpg画像を埋め込む
25:36 3.4 ブックとシートの処理を解説する マクロを記録したら F1ヘルプも見ようよ・・・
28:12 3.5 Add系の追加メソッドでオブジェクトが返るので変数に入れて使うと便利です
35:05 4.おわりの挨拶
36:03 次回の予告 ppスライド画像とシェイプの一覧をExcelシートへ書き込む
38:45 再度説明と確認を行う 要求仕様の機能と合っているか？再テストで確認する

---

2.失敗パターンと成功パターンを先に見せる

2.1 失敗例 マクロ記録のActiveSheet.Pictures.Insertをそのまま使うと
実行確認
保存後、再度確認で開くと・・・

2.2 成功例 Shapes.AddPictureを使う
実行確認
保存後、再度開く

3.コードの解説と言い訳

マクロ記録で作成したコードをよく見ないで、使用したら失敗した。
テストも甘く、不具合・バグに気が付くのが遅れた・・・

3.1 パワポのスライドからjpgを作成するのは簡単で Slides(p).Export "ファイル名", "jpg"

下記、過去の動画宣伝も兼ねてPowerPointのスライドからjpg画像を作成する
https://youtu.be/xWqXdxGE8XU?si=bmJGXWmv7ACLAoAt&t=13
↑のテストコードを実行してみる

'3.ループで回して1ページ目からスライドを.Exportで画像出力
Sub test003()
    Dim strPATH As String  '保存場所 現在と同じPATHにしたい
    strPATH = ActivePresentation.Path  '保存場所パス
    
    Dim strFILENAME As String  '出力ファイル名
    Dim p As Integer
    
    For p = 1 To ActivePresentation.Slides.Count
        strFILENAME = strPATH & "\YouTubeサムネ" & Format(p, "000") & ".jpg"
        'Slides(p)をjpg画像出力
        ActivePresentation.Slides(p).Export strFILENAME, "jpg"
        '↑pページ目のスライドをjpg出力
    Next
    
    MsgBox "終了"
    
End Sub

3.2 マクロ記録でjpgの挿入を探る よく確認しないで使用した私のミス

マクロ記録でコードを探って、コピペで使う。
便利なんだけど、
私のように確認しないで使うと、痛い目にあいます。

再度、
ActiveSheet.Pictures.Insert
が、そのままだとリンク貼り付けになることを説明する

3.3 Shapes.AddPictureを使い リンクをFalseにしてjpg画像を埋め込む

' 画像を0,0へ 埋め込み形式で挿入 ファイル名,リンク,保存保持,left,top,Width,Height
Set picShape = shNEW.Shapes.AddPicture(strJPGNAME, False, True, 0, 0, -1, -1)

'起動済みの既存 パワーポイントのスライドからjpgを作成後、シートに画像を貼る
'ex:新規ブックを追加して、pp:スライドをex:シート単位で貼り付ける
Sub test20240312_02ppスライドからjpgを作成後シード別に貼り付ける()

    Dim ppApp As Object 'As PowerPoint.Application
    
    Set ppApp = Nothing 'エラーチェックのため初期化
    On Error Resume Next  '取得エラー時に次へ行く
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね"
        Exit Sub
    End If
    
    '新規に貼り付け先のExcelブックを作成したいので
    Dim wbNEW As Workbook
    Set wbNEW = Workbooks.Add  '新規ブックの追加
    
    Dim shNEW As Worksheet '新規のシート用に変数を作成する
    
    Dim strJPGNAME As String  '一時保存する名前
    strJPGNAME = ThisWorkbook.Path & "\ppスライドtemp.jpg"

    Dim picShape As Shape  '画像は(も)Shape

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    
    'パワポのスライド情報をExcelシートに書き込む
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pp画像を用意する 単純に.Exportでテンポラリ画像を作成
        ppApp.ActivePresentation.Slides(p).Export strJPGNAME, "JPG"
        DoEvents  '↑jpgファイルを作成しているので、念のため
        
        '画像をシートへ貼る Pictures.InsertがActiveSheetだったので※後で調べる・・・
        Set shNEW = wbNEW.Sheets.Add(Before:=wbNEW.Worksheets(wbNEW.Worksheets.Count))
        '新規シートを一番後ろに追加するために↑細工してみた

        shNEW.Name = "スライド" & p   'シート名をスライド1,2,3..にする
        
        shNEW.Range("A1").Select      '貼付け位置をA1にする

        ' 画像を0,0へ 埋め込み形式で挿入 ファイル名,リンク,保存保持,left,top,Width,Height
        Set picShape = shNEW.Shapes.AddPicture(strJPGNAME, False, True, 0, 0, -1, -1)
        
        picShape.Name = "ppスライド" & p
        picShape.Width = 480   '挿入後幅を調整する
    Next
    
    MsgBox "処理終了、画像を確認してください"

End Sub

3.4 ブックとシートの処理を解説する マクロを記録したら F1ヘルプも見ようよ・・・

新規ブックの追加
新規シートの追加
シート名の変更

をマクロ記録してみます

記録したコードの気になるプロパティやメソッド部分でF1を押すとヘルプが表示されます。
ヘルプのコードも確認しましょうね。

3.5 Add系の追加メソッドでオブジェクトが返るので変数に入れて使うと便利です

'新規に貼り付け先のExcelブックを作成したいので
Dim wbNEW As Workbook
Set wbNEW = Workbooks.Add '新規ブックの追加
や
'画像をシートへ貼る Pictures.InsertがActiveSheetだったので※後で調べる・・・
Set shNEW = wbNEW.Sheets.Add(Before:=wbNEW.Worksheets(wbNEW.Worksheets.Count))
'新規シートを一番後ろに追加するために↑細工してみた

など、
Add系の追加メソッドでオブジェクトが返るので変数に入れて使うと便利です

4.おわりの挨拶 と 次回予告

いつも、こんな感じで失敗してます。
次回の内容をチラ見せすると、

今回、シートにスライドイメージを落としたので、
ついでに
前回のExcelへシェイプの一覧
https://www.youtube.com/live/o0PVL1v27Ts?si=DJT8vQuXkWA1fupX&t=179
をプラスして、みます。

この失敗解説が、何かのヒントになれば幸いです。

---