| |
▼初心者 さん、Yuki さん：
横からスミマセン。
>(3)について
>>' // XL グラフを Picture 形式でコピー
>>Sh.ChartObjects(i).CopyPicture xlScreen, xlPicture
>Sh.ChartObjects(i).CopyPicture xlScreen, xlBitmap
>にすれば
>.Cut と .Paste <= は要らなくなりますね。
なるほどです。
ただ、
> .CopyPicture xlScreen, xlBitmap
にすると、グラフの枠線の上と左が消えてコピーされませんか？
環境のせいかもしれません。
で、一応、元の方式
Picture形式でコピーして、CUTして BMP形式にする方法
でのサンプルです。
Sub XLCharts_PasteSpecial_xlBitMap()
' // グラフウインドウとなっているものは対象外です。
Dim ppApp As Object ' PowerPoint.Application
Dim ppPst As Object ' PowerPoint.Presentation
Dim ppSld As Object ' PowerPoint.Slide
Dim Sht As Worksheet
Dim Obj As Object
Dim iCount As Integer
Dim sngPosOffset As Single
Dim i As Long
' // PowerPoint(以下PP) 定数
Const ppLayoutBlank = 12
Const ppPasteBitMap = 1
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)
' // XL 処理グラフ数カウンタ
iCount = 0
' // PP グラフ貼り付け位置初期値
sngPosOffset = 0
' // XL グラフの貼り付け開始
For Each Sht In ActiveWorkbook.Worksheets
For i = 1 To Sht.ChartObjects.Count
' // XL グラフを Picture 形式でコピー
Sht.ChartObjects(i).CopyPicture xlScreen, xlPicture
' // PP 新規スライド挿入
iCount = iCount + 1
Set ppSld = ppPst.Slides.Add(Index:=iCount, _
Layout:=ppLayoutBlank)
' // PP 貼り付け
ppSld.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Cut
With ppSld.Shapes.PasteSpecial(ppPasteBitMap)
' // PP グラフ位置・サイズ補正
.LockAspectRatio = msoTrue
.Top = sngPosOffset
.Left = sngPosOffset
.Height = .Height * 0.5 ' // 50%縮小
End With
Next i
Next Sht
If iCount = 0 Then
ppApp.Quit
Else
AppActivate Application.Caption
MsgBox CStr(iCount) & _
"枚のグラフを処理しました", vbInformation
End If
Bye_:
On Error GoTo 0
Set ppApp = Nothing: Set ppPst = Nothing
Set ppSld = Nothing: Set Sht = Nothing
Exit Sub
Err_:
MsgBox Err.Description, vbCritical
Resume Bye_
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
