Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


22244 / 76734 ←次へ | 前へ→

【59873】エクセルグラフをパワーポイントに張り付けるには
質問  初心者  - 09/1/15(木) 8:41 -

引用なし
パスワード
   おはようございます。

以下のことを実現したいのですが処理がうまくいかず、
教えて頂きたく、投稿いたしました。

(1)エクセルにあるグラフをパワーポイントに張り付けたい。
→これは問題なく処理できる。
(2)エクセルのシートには複数グラフがあり、1つのスライドに1つのグラフを張り付けて、全部貼り付けが完了するまで貼り付けを繰り返す。
→2個目のグラフを2枚目のスライドに貼り付けの「領域を超えています」と処理が止まってします。
(3)拡張メタでパワーポイントに貼り付けたグラフを切り取り、ビットマップで貼り付けを再度行いたい。
→この部分は記述自体がよく理解できていません。

(2)と(3)がうまく処理できないでいます。

#################################################################
Sub XLグラフをPPに貼り付け()

' // グラフウインドウとなっているものは対象外です。

Dim ppApp As Object ' PowerPoint.Application
Dim ppPst As Object ' PowerPoint.Presentation
Dim ppSld As Object ' PowerPoint.Slide
Dim Sh As Worksheet
Dim Obj As Object
Dim iCount As Integer
Dim sngPosOffset As Single
Dim i As Long

' // PowerPoint(以下PP) 定数
Const ppLayoutBlank = 12
Const ppPasteEnhancedMetafile = 2

' // PP 起動
On Error Resume Next
Set ppApp = CreateObject("PowerPoint.Application")
If ppApp Is Nothing Then Err.Raise 1000, , "PowerPoint cannot be started."
On Error GoTo Err_

' // PP を表示する
ppApp.Visible = True
' // PP 新規プレゼンテーション作成
Set ppPst = ppApp.Presentations.Add(WithWindow:=True)
' // PP 新規スライド挿入
Set ppSld = ppPst.Slides.Add(Index:=1, _
Layout:=ppLayoutBlank)
' // XL 処理グラフ数カウンタ
iCount = 0
' // PP グラフ貼り付け位置初期値
sngPosOffset = 0

' // XL グラフの貼り付け開始
For Each Sh In ActiveWorkbook.Worksheets
For i = 1 To Sh.ChartObjects.Count
' // XL グラフを Picture 形式でコピー
Sh.ChartObjects(i).CopyPicture xlScreen, xlPicture
' // PP 貼り付け
ppSld.Shapes.Paste
' // PP グラフ位置・サイズ補正
With ppSld.Shapes(i)   '(2)2個目のグラフ貼り付けはここで処理が止まる。
'(3)拡張メタで貼り付けたグラフを切り取り
.Cut
'(3)ビットマップ形式で貼り付け    
.paste xbitmap   
.LockAspectRatio = msoTrue
.Top = sngPosOffset
.Left = sngPosOffset
.Height = .Height * 0.5 ' // 50%縮小
End With
' // PP 新規スライド挿入
Set ppSld = ppPst.Slides.Add(Index:=1, Layout:=ppLayoutBlank)

' // XL 処理グラフ数カウンタ
iCount = iCount + 1
Next i
Next Sh
If iCount = 0 Then ppApp.Quit
MsgBox CStr(iCount) & "枚のグラフを処理しました", vbInformation

Bye_:
On Error GoTo 0
Set ppApp = Nothing: Set ppPst = Nothing
Set ppSld = Nothing: Set Sh = Nothing
Exit Sub
Err_:
MsgBox Err.Description, vbCritical
Resume Bye_
End Sub

よろしくお願いいたします。
3 hits

【59873】エクセルグラフをパワーポイントに張り付けるには 初心者 09/1/15(木) 8:41 質問
【59876】Re:エクセルグラフをパワーポイントに張り... Yuki 09/1/15(木) 10:29 発言
【59877】Re:エクセルグラフをパワーポイントに張り... kanabun 09/1/15(木) 11:11 発言
【59880】Re:エクセルグラフをパワーポイントに張り... Yuki 09/1/15(木) 11:39 発言
【59883】Re:エクセルグラフをパワーポイントに張り... 初心者 09/1/15(木) 13:23 質問

22244 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free