71本目：パワーポイントへグラフを貼り付け

出題：パワーポイントへグラフを貼り付け

#VBA100本ノック 71本目
アクティブシートには「グラフ1」があります。
ブックと同一フォルダにプレゼン1.pptxがあり、1スライド目に「図1」のオブジェクトがあります。
「図1」を「グラフ1」に差し替えてください。
縦横比維持して元の「図1」の大きさの範囲に収めてください。

◇ 出題ページはこちら

ソースコード

Option Explicit

' 100本ノック071：パワーポイントへグラフを貼り付け
Sub グラフをprezen1の第1スライドにコピーする()
    
    ' 各オブジェクトの取得
    Dim Appパワポ As PowerPoint.Application
    Set Appパワポ = CreateObject("PowerPoint.Application")

    Dim ppt貼付先 As Presentation
    Set ppt貼付先 = Appパワポ.Presentations.Open(ThisWorkbook.Path & "\prezen1.pptx")
    
    Dim slide貼付先 As Slide
    Set slide貼付先 = ppt貼付先.Slides(1)

    Dim shp貼付目標 As PowerPoint.Shape
    Set shp貼付目標 = slide貼付先.Shapes("図1")
    
    Dim shpコピー元グラフ As Chart
    Set shpコピー元グラフ = WSグラフ.ChartObjects(1).Chart

    ' Excelからパワポへ図として貼り付け
    shpコピー元グラフ.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Dim shp貼付グラフ As PowerPoint.ShapeRange
    Set shp貼付グラフ = slide貼付先.Shapes.Paste

    ' 縦横比を固定して幅を拡大
    shp貼付グラフ.LockAspectRatio = msoTrue
    shp貼付グラフ.Width = shp貼付目標.Width
    
    ' 高さがオーバーしていたら縮小
    If shp貼付グラフ.Height > shp貼付目標.Height Then
        shp貼付グラフ.Height = shp貼付目標.Height
    End If
    
    ' グラフを図のセンターに配置
    Dim height差 As Double: height差 = shp貼付目標.Height - shp貼付グラフ.Height
    shp貼付グラフ.Top = shp貼付目標.Top + height差 / 2
    Dim width差 As Double: width差 = shp貼付目標.Width - shp貼付グラフ.Width
    shp貼付グラフ.Left = shp貼付目標.Left + width差 / 2

    ' 元図形を削除
    shp貼付目標.Delete
    
    ' 保存して終了
    ppt貼付先.Save
    Appパワポ.Quit

End Sub

解説

ExcelのグラフをPowerPointへ貼り付ける問題でした。

この手の他アプリ操作コードはオブジェクトが大量に出てきますが、
これをサボらずにひとつずつ変数にすることが重要です。

後で改修する際に本当に訳が分からなくなりがちですからね。

「As」の型を調べるのがちょっと大変ですが、
ここをがんばっておくと理解も深まりますので是非勉強してみて下さい。

PowerPointの操作に関する説明は省略します。

割とストレートで読みやすいコードになっていると思いますので、
本コードを眺めながら勉強してみてください。