Excel2003で作成したファイルをセル１つずつ単体で画像ファイルに保存したい

質問

Excel2003で、普通に文字をセルに入力し、それを画像ファイル（BMP・GIF・PNG・JPEGのいずれか）に保存したいのですが、何か良い方法はありませんか。ただ、たくさんの画像ファイルを作りたいので、Excelのセルをそのままコピーして、わざわざペイントソフトを起動して貼り付けるのではない方法、できれば、保存したい文字を先にすべて入力しておいて、あとからセルごとに保存できるとかいう方法もありましたら教えてください。

回答No.2

KenKen_SP · ベストアンサー

#1 です。ちょいと長いですが。。。

0.　C:\images フォルダを予め作成しておく
1.　[Alt]+[F11] で VBE を開く
2.　[挿入]-[標準モジュール]
3.　下記のソースコードをコピペ
4.　VBE を閉じる
5.　適当なセルにデータを入力し、そのセルを飛び飛びでも良いので
　　選択してから、[ツール]-[マクロ]-[マクロ]で実行

BMP（ビットマップ）ならこんな感じ。Jpeg や Gif でも書き出せるけど
少し複雑になります。

細かなエラー処理はしてません。

' // ソースコードはここから下
Option Explicit

' // 標準モジュール
' // Declareations --------------------------------------------------
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
　　　　ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
　　　　ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
　　　　ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
　　　　ByRef lpPictDesc As PictDesc, _
　　　　ByRef RefIID As GUID, _
　　　　ByVal fPictureOwnsHandle As Long, _
　　　　ByRef IPic As IPicture) As Long
' // Types ----------------------------------------------------------
Private Type PictDesc
　　　　cbSizeofStruct As Long
　　　　picType　　　　As Long
　　　　hImage　　　　 As Long
　　　　Option1　　　　As Long
　　　　Option2　　　　As Long
End Type
Private Type GUID
　　　　Data1　　　　　As Long
　　　　Data2　　　　　As Integer
　　　　Data3　　　　　As Integer
　　　　Data4(7)　　　 As Byte
End Type
' // Constants ------------------------------------------------------
Private Const CF_BITMAP　　　As Long = 2
Private Const CF_PALETTE　　 As Long = 9

' // ここがメイン処理部
Sub セルごとにビットマップで書き出し()

　　Dim r　　　 As Range
　　Dim sImgDir As String
　　Dim lImgCnt As Long
　　Dim p　　　 As IPicture

　　' // 画像の保存フォルダパス
　　sImgDir = "C:\images"

　　' // 終了条件:: 選択されているのがセル以外なら無視
　　If UCase$(TypeName(Selection)) <> "RANGE" Then Exit Sub

　　lImgCnt = 1
　　For Each r In Selection.Cells
　　　　' // ビットマップとしてクリップボードへコピー
　　　　r.CopyPicture Appearance:=xlScreen, _
　　　　　　　　　　　Format:=xlBitmap
　　　　' // クリップボードのビットマップを Picture オブジェクトに変換
　　　　Set p = CreatePictureFromClipboard()
　　　　If Not p Is Nothing Then
　　　　　　' // BMPファイルを書き出す
　　　　　　Call SavePicture(p, sImgDir & "\image" & Format$(lImgCnt, "00000") & ".bmp")
　　　　　　lImgCnt = lImgCnt + 1
　　　　　　Set p = Nothing
　　　　End If
　　Next
　　' // フォルダを開く
　　Shell "explorer.exe " & Chr(34) & sImgDir & Chr(34), vbNormalFocus

End Sub

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

　　Dim hBitmap　　　 As Long
　　Dim hPalette　　　As Long
　　Dim uPic　　　　　As PictDesc
　　Dim IID_IDispatch As GUID
　　Dim lRet　　　　　As Long

　　Set CreatePictureFromClipboard = Nothing

　　' 終了条件:: クリップボードに該当データが無い
　　If IsClipboardFormatAvailable(CF_BITMAP) = 0& Then Exit Function
　　' 終了条件:: クリップボードからイメージハンドルが取得できない
　　If OpenClipboard(0&) <> 0& Then
　　　　hBitmap = GetClipboardData(CF_BITMAP)
　　　　hPalette = GetClipboardData(CF_PALETTE)
　　　　Call CloseClipboard
　　End If
　　If hBitmap = 0& Then Exit Function

　　With uPic
　　　　.cbSizeofStruct = Len(uPic)
　　　　.picType = 1
　　　　.hImage = hBitmap
　　　　.Option1 = hPalette
　　End With
　　With IID_IDispatch
　　　　.Data1 = &H20400
　　　　.Data4(0) = &HC0
　　　　.Data4(7) = &H46
　　End With
　　lRet = OleCreatePictureIndirect(uPic, _
　　　　　　　　　　　　　　　　　　IID_IDispatch, _
　　　　　　　　　　　　　　　　　　0&, _
　　　　　　　　　　　　　　　　　　CreatePictureFromClipboard)

End Function

お礼

ありがとうございます。
解決しました！

回答No.1

KenKen_SP

こんばんは。

> 保存したい文字を先にすべて入力しておいて、あとからセルごとに
> 保存できるとかいう方法

VBA を使えば可能ですけど、具体的にどのようにデータが並んでいる
のでしょうか？

また、「セルごと」というのは、ひとつのセルで画像1ファイル？
連続しない選択範囲ごと？

この辺を具体に補足して下さい。

お礼

早速のご回答ありがとうございます。
普通に文字だけを使用していて、グラフや画像などは一切貼り付けていない、単純な文字列のみを使用した形のデータです。
配置はＡの列にズラーッとたて一列に並んでいます。

セルごとというのは、ひとつのセルで画像１ファイルです。

わかりにくい表現ですみませんが、こんな感じです。