VBScriptでExcelのグラフを貼り付け(書式保持)

VBScriptでExcelのグラフを書式保持したままPowerPointに
貼り付けようとしています。
１つのスライドの中に９つShapeがあり、８つ目に貼り付けます。
----------------------------------------------------
set oPpp = CreateObject("PowerPoint.Application")
oPpp.ActivePresentation.slide(1).select
oPpp.ActivePresentation.slide(1).shape.item(8).select
oPpp.ActivePresentation.slide(1).shape.paste
----------------------------------------------------
をしたら図としては上手く貼り付けられたのに
書式を保持しようとしたら
----------------------------------------------------
set oPpp = CreateObject("PowerPoint.Application")
oPpp.ActivePresentation.slide(1).select
oPpp.ActivePresentation.slide(1).shape.item(8).select
oPpp.ActivePresentation.slide(1).shape.pastespecial 0
----------------------------------------------------
エラーが起きました。

書式を保持したままExcelのグラフを保持するコードって
ありませんか?

ご存知の方、教えてください。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/11/04 21:12

#1です。

サンプル付け忘れました
プロシージャではありません

Dim ptApp As Object, ptPrs As Object, ptSlide As Object
Dim s As Integer
Dim x As Double, y As Double, h As Double, w As Double

Set ptApp = CreateObject("PowerPoint.Application")
ptApp.Visible = True
ptApp.Activate
'"C:\Desktop\XX.pptx" 仮Filepath
Set ptPrs = ptApp.presentations.Open("C:\Desktop\XX.pptx")
Set ptSlide = ptPrs.Slides(1)
ptSlide.Select
'以下該当部分
s = ptSlide.Shapes.Count
Sheet1.ChartObjects(1).Chart.ChartArea.Copy 'Excel Chart
ptApp.CommandBars.ExecuteMso ("PasteExcelChartSourceFormatting")
'ループがないと正しく貼り付けシェイプを認識しない
Do
DoEvents
Loop Until ptSlide.Shapes.Count > s
'貼り付け終了
'以下シェイプ操作
With ptSlide.Shapes(8)
x = .Top
y = .Left
h = .Height
w = .Width
.Delete
End With

With ptSlide.Shapes(ptSlide.Shapes.Count)
.Top = x
.Left = y
.Height = h
.Width = w
End With
ptApp.CommandBars.ReleaseFocus

この回答へのお礼

ありがとうございました。グラフを貼り付けることができました。
しかし、色が変わりました。

お礼日時：2021/11/08 11:00

No.1 回答者： Qchan1962 回答日時： 2021/11/04 21:08

こんばんは

あまり知識はありませんが、、
＞書式を保持したままExcelのグラフを貼り付ける
Excel側のVBAだと出来なかったような記憶があります。
Excelの標準モジュールに書いて実行、PowerPointを開き
インスタンスされたPowerPointVBAを使う、、みたいな事だったかと、、
あまり良く覚えていませんが、
自身で昔作ったものを見つけたので、一応サンプルとして掲示します。

＞１つのスライドの中に９つShapeがあり、８つ目に貼り付けます。
既存の８つ目のShapeは削除して代わりに同じ位置同じサイズで貼り付けるで良いでしょうか？
サンプルは、グラフのあるExcel側シートオブジェクトを
オブジェクト名Sheet1としています。グラフインデックスは1です