| |
おはようございます。
以下のことを実現したいのですが処理がうまくいかず、
教えて頂きたく、投稿いたしました。
(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
よろしくお願いいたします。
|
|
初心者
- 09/1/15(木) 8:41 -
