EXCELでアクティブなワークシートのグラフを連続印刷するorPPTに1グラフ／1ページで貼り付ける

質問

EXCEL2000(windows XP)環境にて、現在アクティブなワークシートにあるグラフ(埋め込みグラフ)を連続印刷する方法を教えてください。

例えば、ワークシート中に50枚のグラフが配置されているとき、これらを全て印刷したいのですが、いちいち印刷メニューからだと手間がかかり、これを何とかできればと考えています。

アクティブなワークシート中の任意の選択されたグラフを印刷できるとナオいいです。

更に、PPT等に1グラフ／1ページで出力(カット&ペースト)をマクロやVBA等で自動できれば最高です。

ここを見れば、にたようなことができるという情報でも歓迎します。
どうぞよろしくお願いいたします。

回答No.6

KenKen_SP · ベストアンサー

なるほど、いいアイディアですね^^

では、さらにこのアイディアを応用して、ワークシート経由ではなく、

> oChart.Copy
> ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)"
> Selection.Cut

　　↓

oChart.CopyPicture xlScreen, xlPicture

直接拡張メタファイルでクリップボードにコピーするようにするとか？

> office系アプリの操作に関して参考になるソース

有名どこで。
http://www.moug.net/
http://www.asahi-net.or.jp/~ef2o-inue/top01.html
http://www.officetanaka.net/

意外と重宝。
http://support.microsoft.com/select/?target=hub

Google で検索すればいっぱいありますよ。その中から「お気に入り」を
探すこともスキルアップには大切なことだと思います^^

お礼

お返事遅くなりスイマセン。
質問者です。

ためしてみました。スゴイ。はやい。生産性が格段に高くなりました(特に継続的にEXCELを使いたいときに）

ご紹介いただいたURLにていろいろ勉強させていただきます。
どうもありがとうございました。

回答No.7

noname#22650

こんばんは venzoです。

＞oChart.CopyPicture xlScreen, xlPicture
2000の環境で動作確認しました。
CopyPictureというメソッドは知りませんでした。
こちらの方がスマートだし、処理速度も速いです。すばらしい！

＞このようなVBAを使ったoffice系アプリの操作に関して参考になるソース
私の場合、Excelでマクロを記録して、それを改造することが多いです。
分からないことは、Google検索が中心です。
あまり参考にならないですね（＾＾；

お礼

最新バージョンのマクロ、ほんとうに早いです。

マクロの勉強方法。そうかマクロを記録すればいいんですね。
特にメソッド関係はそこから学習できることよくわかりました。

どうもありがとうございます。

回答No.5

noname#22650

思いつきました。PowerPointで出来ないなら、ExcelでPasteSpecialすれば良い。

>' PP スライド追加し、拡張メタファイル Excel グラフを貼り付け
>oChart.Copy

↑この部分を↓こう変更。

' PP スライド追加し、拡張メタファイル Excel グラフを貼り付け
oChart.Copy
ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)"
Selection.Cut

いったんExcelの方にメタファイルで貼り付けて、切り取って、PPTに貼り付け。
これでどうでしょう？

お礼

venzoさん、こんにちは。

できました！！
サイズも非常に小さくてGOODです。

どうもありがとうございます。
これで当初考えたことが全て完璧に実現することができました。

補足

venzoさん、KenKen_SPさん

本当にありがとうございました。

別質問なので本当は別のと頃で聞いた方がよいのだと思いますが、このようなVBAを使ったoffice系アプリの操作に関して参考になるソース(海外に居住しているためWebページの方が助かります)がありましたら教えてください。

自分でも聞いているばかりでなくて、基本的なところを勉強して自力でも解決できるようになりたいと考えております。

回答No.4

KenKen_SP

こんにちは。KenKen_SP です。

> PowerPoint2000には、メソッド"PasteSpecial"が無いようです。

大量のグラフが埋め込まれる場合を考慮し、拡張メタファイルで
貼り付けた方が良いかなと思ったのですが...

venzo さん、理由がわかってスッキリしました。
ありがとうございました。

お礼

KenKen_SPさん

そうなんです。実はエクセルのファイルが10MBをこえており、かつ、グラフが大量にあるので貼り付けるときに、2000で動作するバージョンだと動作はするのですが、大変時間がかかり(本質的には自動なので問題なしですが)、かつ、大きくなってしまいます。

可能なら拡張メタファイルでできたらと思っていますが、メソッドがないとなると難しそうですね。

一度暫定的なエクセルファイルを作成してそちらに図をコピペしてから実行するなど工夫して回避できるか試してみるつもりです。

どうもありがとうございました。

回答No.3

noname#22650

こんにちは、お邪魔します。
Excel2000、PowerPoint2000で確認しました。

PowerPoint2000には、メソッド"PasteSpecial"が無いようです。
ヘルプで検索しましたがヒットしませんでした。
オブジェクトブラウザで検索してもダメでした。

代わりに"Paste"を使うしかないと思います。

＃１のソースの場合
>ppSld.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
ppSld.Shapes.Paste

＃２のソースの場合
>With ppSld.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
With ppSld.Shapes.Paste

上記の変更でどちらのソースでも動きました。

お礼

venzoさん、ありがとうございます。
確かに2000の環境下で所望の動作しました。

回答No.2

KenKen_SP

Excel2002+PowerPoint2002 では動きますね.... Office2000 環境がないので
どうも良くわからないのですが、バージョンの差異なのかもしれません。
試しに...

> ppSld.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
> ' PP グラフ位置・サイズを最大になるように補正
> With ppSld.Shapes(1)
> 　　.LockAspectRatio = msoFalse
> 　　.Top = 0
> 　　.Left = 0
> 　　.Height = sngH
> 　　.Width = sngW
> End With

の部分を下記のように変えてみたらどうなりますか？

' PP グラフ位置・サイズを最大になるように補正
With ppSld.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
　　.LockAspectRatio = msoFalse
　　.Top = 0
　　.Left = 0
　　.Height = sngH
　　.Width = sngW
End With

回答No.1

KenKen_SP

こんにちは。KenKen_SP です。

PP の VBA はほとんど使わないので、勉強ついでにコードを書いてみました。
こんな感じで良かったのかな？ ほとんどテストしてないけど。

　# GetSelectedChats 関数部はもっと良い方法がありそうな気がします

標準モジュールにコピペして下さい。

Sub 選択グラフを印刷()

　　Dim colCharts As Collection
　　Dim oChart　　As Object

　　On Error GoTo ERROR_HANDLER

　　Set colCharts = GetSelectedChats
　　If Not colCharts Is Nothing Then
　　　　For Each oChart In colCharts
　　　　　　' プレビューしない場合は Preview:=False に修正
　　　　　　oChart.Chart.PrintOut Preview:=True
　　　　Next
　　End If
　　Set colCharts = Nothing

TERMINATE:
　　On Error GoTo 0
　　Exit Sub
ERROR_HANDLER:
　　MsgBox Err.Description, vbCritical
　　Resume TERMINATE
End Sub

Sub 選択グラフを新規PPにコピペ()

　　' 拡張メタファイルで貼り付けてます（Excel2002+PowerPoint2002）

　　Dim ppApp　　 As Object ' PowerPoint.Application
　　Dim ppPst　　 As Object ' PowerPoint.Presentation
　　Dim ppSld　　 As Object ' PowerPoint.Slide
　　Dim colCharts As Collection
　　Dim oChart　　As Object
　　Dim sngW　　　As Single
　　Dim sngH　　　As Single
　　Dim i　　　　 As Long

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

　　' 選択されている ChartObject 取得
　　Set colCharts = GetSelectedChats
　　' 終了条件:: 選択されたグラフが無い
　　If colCharts Is Nothing Then Exit Sub
　　' 終了条件:: PP が起動できない
　　On Error Resume Next
　　Set ppApp = CreateObject("PowerPoint.Application")
　　If ppApp Is Nothing Then
　　　　On Error GoTo ERROR_HANDLER
　　　　Err.Raise 1000, , "PowerPoint の起動に失敗しました"
　　End If

　　On Error GoTo ERROR_HANDLER
　　' PP を表示
　　ppApp.Visible = msoTrue
　　' PP 新規プレゼンテーション作成
　　Set ppPst = ppApp.Presentations.Add(WithWindow:=True)
　　' PP 画面最大サイズを取得
　　With ppPst.PageSetup
　　　　sngH = .SlideHeight
　　　　sngW = .SlideWidth
　　End With
　　' Excel グラフの貼り付け開始
　　i = 1
　　For Each oChart In colCharts
　　　　' PP スライド追加し、拡張メタファイル Excel グラフを貼り付け
　　　　oChart.Copy
　　　　Set ppSld = ppPst.Slides.Add(Index:=i, _
　　　　　　　　　　　　　　　　　　 Layout:=ppLayoutBlank)
　　　　ppSld.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
　　　　' PP グラフ位置・サイズを最大になるように補正
　　　　With ppSld.Shapes(1)
　　　　　　.LockAspectRatio = msoFalse
　　　　　　.Top = 0
　　　　　　.Left = 0
　　　　　　.Height = sngH
　　　　　　.Width = sngW
　　　　End With
　　　　i = i + 1
　　Next

TERMINATE:
　　On Error GoTo 0
　　Set colCharts = Nothing
　　Set ppApp = Nothing
　　Set ppPst = Nothing
　　Set ppSld = Nothing
　　Exit Sub
ERROR_HANDLER:
　　MsgBox Err.Description, vbCritical
　　Resume TERMINATE
End Sub

' // 選択された ChartObject を Collection で返す
Private Function GetSelectedChats() As Collection

　　Dim Obj　　　　 As Object
　　Dim bFoundChart As Boolean
　　Dim colCharts　　As Collection

　　On Error GoTo ERROR_HANDLER

　　' 終了条件:: Selection が Range
　　If UCase$(TypeName(Selection)) = "RANGE" Then Exit Function

　　' Selection から ChartObject を探す
　　Set colCharts = New Collection
　　If UCase$(TypeName(Selection)) = "DRAWINGOBJECTS" Then
　　　　' 複数選択のとき
　　　　For Each Obj In Selection
　　　　　　If UCase$(TypeName(Obj)) = "CHARTOBJECT" Then
　　　　　　　　colCharts.Add Obj
　　　　　　End If
　　　　Next
　　Else
　　　　' 単一選択のとき
　　　　Set Obj = Selection
　　　　If UCase$(TypeName(Obj)) <> "CHARTOBJECT" Then
　　　　　　Do While UCase$(TypeName(Obj)) <> "APPLICATION"
　　　　　　　　Set Obj = Obj.Parent
　　　　　　　　If UCase$(TypeName(Obj)) = "CHARTOBJECT" Then
　　　　　　　　　　bFoundChart = True
　　　　　　　　　　Exit Do
　　　　　　　　End If
　　　　　　Loop
　　　　Else
　　　　　　bFoundChart = True
　　　　End If
　　　　If bFoundChart Then colCharts.Add Obj
　　End If
　　' Return
　　If colCharts.Count > 0 Then Set GetSelectedChats = colCharts

TERMINATE:
　　On Error GoTo 0
　　Set colCharts = Nothing
　　Exit Function
ERROR_HANDLER:
　　Set GetSelectedChats = Nothing
　　Resume TERMINATE
End Function

お礼

ありがとうございました。
前半の印刷するバージョンは問題なく動作しました。
後半のPPTの方ですが、パワーポイントとエクセルのバージョンが2000であることが影響するのか、実行すると(印刷するバージョンで選択した同じスライドを選択した状態)、以下のようなエラーが発生します。

「オブジェクトは、このプロパティまたはメソッドをサポートしていません」

マイクロソフトエクセルからのエラーとなります。
エラーが発生する前にパワーポイントが起動し、1枚目にまっさらのスライドが挿入されたエラーとなります。

ブレイクポイントを設定してどこで止まるかを見たところ、
With ppSld.Shapes(1)
の行でエラーが発生しているようです。
なにか回避方法等がおもいつきましたら教えてください。