Excel2007のVBAで、セル範囲を指定し

質問

Excel2007のVBAで、セル範囲を指定して画像として保存したいです。

たとえば、
Worksheets("Sheet1").Range("A1:B10").CopyPicture xlScreen, xlBitmap
Worksheets("Sheet2").Paste

とすれば、別のシートに指定した範囲を画像にすることはでき、

さらにこれを、
With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, "C:\test.html", _
"Sheet2", "", xlHtmlStatic, "image", "")
.Publish (True)
.AutoRepublish = False
End With

とすれば、画像を指定した場所に保存することはできると思います。

ただ、これだと無駄な処理をしているような気がしますし、実際時間も数秒必要です。

これが、グラフだと
Worksheets("Sheet1").ChartObjects("グラフ1").Chart.Export Filename:="C:\graph.gif", FilterName:="gif"

のように簡単に、しかも短時間で出来ます。

できれば、上記グラフのように、指定したSheetの指定したセル範囲を画像として指定した場所にPNGにて保存したいです。

どなたかご教授いただければ幸いです。

回答No.4

mitarashi · ベストアンサー

苦肉の策の中抜き版です。ConvCLSIDに言及してありませんでしたが、コピーされましたでしょうか。
当方では、下記により、Sub testを実行して、選択セルをpngで保存できました。

Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
Private Declare Function OpenClipboard Lib "user32.dll" ( _
Private Declare Function GetClipboardData Lib "user32.dll" ( _
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
Private Declare Function GdiplusStartup Lib "gdiplus.dll" _
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" _
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" _
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" _
Private Declare Function CLSIDFromString Lib "ole32" _

' // Types ----------------------------------------------------------
Private Type PictDesc
'略
End Type
Private Type Guid
'略
End Type

Public Enum GDIPlusStatusConstants
'略
End Enum

Private Type UUID
'略
End Type

Private Type GdiplusStartupInput
'略
End Type

Private Type EncoderParameter
'略
End Type

Private Type EncoderParameters
'略
End Type

' // Constants ------------------------------------------------------
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9

Const CLSID_PNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"

Sub test()
Dim myPicture As StdPicture
Selection.Copy
Set myPicture = CreatePictureFromClipboard
Call SavePicturePng(myPicture, "c:\cells.png")
End Sub

' // クリップボードのビットマップデータから Picture オブジェクトを作成
Public Function CreatePictureFromClipboard() As StdPicture
'略
End Function

Public Function SavePicturePng(ByVal PicObj As IPictureDisp, ByVal FName As String) As GDIPlusStatusConstants
'略
End Function

Private Function ConvCLSID(ByVal sGuid As String) As UUID
'略
End Function

お礼

大変ご足労おかけしました。

なんの問題もなく出来上がりました。

これからの作業効率を考えると、感謝感謝です。

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

回答No.3

mitarashi

#1,2です。
まず、
http://okwave.jp/qa/q2885043.html
の、#2の、' // 標準モジュールから、
Public Function CreatePictureFromClipboard() As StdPictureの最後の、
End Functionまでを、コピーして、標準モジュールに貼り付けます。
次いで、
http://hpcgi1.nifty.com/MADIA/VBBBS2/wwwlng.cgi?print+200708/07080012.txt
の「ここからコード」というところの次から、
名称 :SavePicturePngの最後の、End Functionまでを貼り付ける訳ですが、
最初に貼り付けたコードの下記の部分に、相当する部分は、それぞれ分類して貼り付けてください。
最初に貼り付けたコードの下に全部貼り付けてしまうと、エラーになってしまうと思います。

' // Declareations --------------------------------------------------

' // Types ----------------------------------------------------------

' // Constants ------------------------------------------------------
丸ごとコードを載せると、字数制限にとうてい収まりませんし、著作権上の問題も分からないので、控えておきます。
APIというのを用いて、Windowsの機能を使っています。関心を持たれたら、参考URLなどをご覧下さい。

参考URL：

http://www.excellenceweb.net/vba/api/what_windows_api.html

お礼

ご丁寧にありがとうございます。

書かれていることは、理解しているつもりですが上手く動きません。

私自身のスキルに問題があると感じております。

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

回答No.2

mitarashi

#1です。
xl2010、WindowsXPsp3環境で動作確認しましたので、報告しておきます。
実行スピードはあっと言う間です。
（xl2007環境は無いものであしからず）
参考URLから、必要なパーツを、標準モジュールにコピペしてから、実行して下さい。
Sub test()
Dim myPicture As StdPicture
Selection.Copy
Set myPicture = CreatePictureFromClipboard
Call SavePicturePng(myPicture, "c:\cells.png")
End Sub

お礼

ご回答ありがとうございます。

>必要なパーツを、標準モジュールにコピペしてから
の意味が良くわからず、、、戸惑っていますが
がんばってみます。

後ほど、ご報告いたします。

補足

試してみましたが、私には無理でした。

もしよろしければ、簡単なサンプルを作っていただけませんでしょうか。

厚かましいお願いですみません。

回答No.1

mitarashi

エクセルでセルをコピーすると、クリップボードには多数の種類のフォーマットでコピーされています。
拡張メタファイル、Picture、ビットマップ、テキスト等々。
ここから、簡単にPNGに変換する方法は存じません。
下記を組み合わせれば出来ると思います。

クリップボードのbitmapからPictureObject生成
http://okwave.jp/qa/q2885043.html
下記の様な使い方で、BMP形式では保存できます。
Sub test()
Selection.Copy
Call SavePicture(CreatePictureFromClipboard, "c:\cell.bmp")
End Sub
残念ながら、SavePictureではBMP（またはEMF）形式でしか保存できないそうなので、

PictureObjectからPNG形式で保存
http://hpcgi1.nifty.com/MADIA/VBBBS2/wwwlng.cgi?print+200708/07080012.txt

なお、拡張メタファイルEMF形式での保存なら下記で出来てしまいます。
Vix等のフリーソフトで読み込んでPNGに変換という事もできますが、多量に処理するので無ければご要望には添いませんね。
Const CF_ENHMETAFILE = 14
Private Declare Function OpenClipboard Lib "user32" (ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As Long) As Long

Sub clip2emf()
Dim hSrcMetaFile As Long
Dim hFileMetaFile As Long

Selection.Copy
If OpenClipboard(0) Then
hSrcMetaFile = GetClipboardData(CF_ENHMETAFILE)
hSrcMetaFile = CopyEnhMetaFile(hSrcMetaFile, vbNullString)
CloseClipboard
End If
If hSrcMetaFile = 0 Then
MsgBox "emf取得に失敗"
Exit Sub
End If
hFileMetaFile = CopyEnhMetaFile(hSrcMetaFile, "c:\test.emf")
DeleteEnhMetaFile hFileMetaFile
DeleteEnhMetaFile hSrcMetaFile
End Sub