Unlock a world of possibilities! Login now and discover the exclusive benefits awaiting you.
Hi Experts
VB Scriptを組んでQVからPPTへオブジェクトをコピーするにあたって、
スクロールバーのついたChartは、画面上に見えている部分しかコピーが出来ません。
表のすべてのデータをコピーして貼り付けたいのですが、どのようなScriptを書けば良いのか分かりません。
ご教示いただけないでしょうか?
Textでコピーすると、全部のデータは取得できますが、表は崩れてしまいます。
Scriptは以下です。
赤字の部分のコードだと、画面に見えているタブの部分しかコピーできません。
よろしくお願い致します。
Sub ExportPPT
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set objPresentation = objPPT.Presentations.Add
For i = 0 To ActiveDocument.NoOfSheets - 3
Set MySheet = ActiveDocument.GetSheet(i)
Set PPSlide = objPresentation.Slides.Add(1,12)
ActiveDocument.ActiveSheet.CopyBitmapToClipboard
ActiveDocument.GetSheetObject("CH01").CopyBitmapToClipboard
objPPT.Visible = True
PPSlide.Shapes.Paste()
Next
Set PPSlide = Nothing
Set PPPres = Nothing
End sub
以下のコードでいかがでしょうか。MyArrayにすべてのすべてのオブジェクトIDを指定しておく必要がありますが。
Sub ExportPPT()
Dim MyArray(1)
MyArray(0) = "CH01"
MyArray(1) = "CH02"
Set PPApp = CreateObject("PowerPoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
For Each Item In MyArray
Set PPSlide = PPPres.Slides.Add(1, 11) 'タイトルのみ
ActiveDocument.GetSheetObject(Item).CopyBitmapToClipboard
PPSlide.Shapes.Paste
Next
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
チャートのX-軸スクロールバーの表示で10に制限しているグラフで10を超えるデータが表示されている場合を想定して、一時的にX-軸スクロールバーの表示をオフにして、グラフの幅を調整しグラフイメージをクリップボードにコピーするようにしてみましたが質問の趣旨に合ってますかね?
Sub ExportPPT()
Dim objPPT
Dim objPresentation
Dim PPSlide
Dim oCh
Dim oRect
Dim oProp
Const ciViewCnt = 10
Dim dOldChWidth
Dim bChgProp
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set objPresentation = objPPT.Presentations.Add
Set PPSlide = objPresentation.Slides.Add(1, 11) 'タイトルのみ
Set oCh = ActiveDocument.GetSheetObject("CH01")
If oCh.GetRowCount >= ciViewCnt Then
'チャートの幅を取得し、データ数に見合った幅に変更
Set oRect = oCh.GetRect()
dOldChWidth = oRect.Width
oRect.Width = dOldChWidth * oCh.GetRowCount / ciViewCnt
oCh.SetRect oRect
'X-軸スクロールバーの表示が有効なら無効に変更
bChgProp = False
Set oProp = oCh.GetProperties()
If oProp.ChartProperties.XAxisScroll Then
oProp.ChartProperties.XAxisScroll = False
oCh.SetProperties oProp
bChgProp = True
End If
oCh.CopyBitmapToClipboard
'X-軸スクロールバーの表示を無効に変更したら有効に戻す
If bChgProp = True Then
oProp.ChartProperties.XAxisScroll = True
oCh.SetProperties oProp
End If
'チャートの幅を元に戻す
oRect.Width = dOldChWidth
oCh.SetRect oRect
Else
oCh.CopyBitmapToClipboard
End If
PPSlide.Shapes.Paste()
Set PPSlide = Nothing
Set PPPres = Nothing
End sub