VBAで画像処理

質問

以下のプログラムは、Ｃ言語で記載されたプラグラムで、画像に鏡映変換を施すプログラムです。
これを、ＥｘｃｅｌＶＢＡでやりたいとおもうのですが、
特に、一度Excelのセルに読みだして、そこで数字を処理してトしたいと考えています。

（単に画像Excelの機能だけをつかってを反転するだけならば、たいしたことではないので
自分で判るのですが、一度配列なりセルに画素情報を読み込む方法は、見当もつかないので
知りたいと思っています。）

ということで、特に以下の（１）、（２）に注意して、ExcelＶＢＡで下記のプログラムを変換する方法を教えてください。よろしくお願いします。

(1)特に、以下の部分の記述がどう変化するか、教えてください。

void main(void)
{
char input[100], output[100];

printf("入力画像ファイル名(input.bmp)："); scanf("%s", input);
printf("出力画像ファイル名(output.bmp)："); scanf("%s", output);

/* 画像の入力 */
readBmp(input, image_in); /* RGB24ビットカラーBMP画像を配列に格納 */

/* 画像処理 */
mirror(image_in, image_out); /* 鏡像を作る */

/* 画像の出力 */
writeBmp(image_out, output); /* RGB24ビット画像をファイルに出力 */
}

(2)特に、一度BMPの画素情報を、Excelのセルに読み込めるようにしていただけると助かります。

＝＝＝＝＝＝＝＝＝

#include <stdio.h>
#include <stdlib.h>

/* 最大画像サイズ */
#define Y_SIZE 1280
#define X_SIZE 1280

/* BMPファイル用 */
typedef short INT2;
typedef long INT4;

INT2 bfType;
INT4 bfSize;
INT2 bfReserved1,
bfReserved2;
INT4 bfOffBits;
INT4 biSize,
biWidth, biHeight;
INT2 biPlanes,
biBitCount;
INT4 biCompression,
biSizeImage,
biXPelsPerMeter,
biYPelsPerMeter,
biClrUsed,
biClrImportant;

#define HIGH 255 /* ２値画像の白 */
#define LOW 0 /* ２値画像の黒 */
#define LEVEL 256 /* 濃度レベル数 */

unsigned char image_in[Y_SIZE][X_SIZE][3]; /* 入力カラー画像配列 */
unsigned char image_out[Y_SIZE][X_SIZE][3]; /* 出力カラー画像配列 */

/* 鏡像を作る(左右逆) */
void mirror(
unsigned char in[Y_SIZE][X_SIZE][3],
unsigned char out[Y_SIZE][X_SIZE][3])
{
int i,j,k;
for (i=0; i<biHeight; i++)
for (j=0; j<biWidth; j++)
for (k=0; k<3; k++)
out[i][j][k] = in[i][biWidth-1-j][k];
}

void main(void)
{
char input[100], output[100];

printf("入力画像ファイル名(input.bmp)："); scanf("%s", input);
printf("出力画像ファイル名(output.bmp)："); scanf("%s", output);

/* 画像の入力 */
readBmp(input, image_in); /* RGB24ビットカラーBMP画像を配列に格納 */

/* 画像処理 */
mirror(image_in, image_out); /* 鏡像を作る */

/* 画像の出力 */
writeBmp(image_out, output); /* RGB24ビット画像をファイルに出力 */
}

回答No.1

mitarashi · ベストアンサー

BMPを読み込むVBAコードは、何日か前に本サイトに投稿されていたと思いますが、既に時の流れの中に埋没していて、ちょっと探してみましたが、見つけられませんでした。
ちょうど、白黒画像の黒画素数を数えたいと思っていたところなので、昔作った（切り貼りした？）コードを引っ張りだしてみました。ご要望とは異なりますが、GDI+のラッパー？クラスを用いる方法です。R, G, Bを別々のワークシートに書き出しています。
詳細はこちらをご参照下さい。
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmGdiClass.html

クラスはこちらからダウンロードして下さい。コメントはフランス語ですが(^^;)中身は自由に見られます。
'http://arkham46.developpez.com/articles/office/clgdiplus/
'Le module clGdiPlus au format cls pour toutes versions d'Office.v2.0 (11/01/11)をダウンロードして解凍
'Excelにインポート
'インポートされたクラスの頭の方の、#Const Access = True -> False に
'Microsoft Forms 2.0 Object Libraryに参照設定

Sub test()
Dim clGdip As ClGdiPlus
Dim retBool As Boolean
Dim lPixels() As Byte
Dim lCptX As Long, lCptY As Long
Dim colorRed As Long, colorGreen As Long, colorBlue As Long
Dim OpenFileName As Variant
Dim srcfile As String
Dim bufR As Variant, bufG As Variant, bufB As Variant
Dim xSize As Long, ySize As Long

OpenFileName = Application.GetOpenFilename("画像ファイル,*.jpg;*.bmp;*.png")
If OpenFileName <> False Then
srcfile = OpenFileName
Else
Exit Sub
End If
ActiveSheet.Cells.Clear
Application.ScreenUpdating = False
Set clGdip = New ClGdiPlus
retBool = clGdip.OpenFile(srcfile)
If Not retBool Then Exit Sub
lPixels = clGdip.GetPixels
xSize = UBound(lPixels(), 2)
ySize = UBound(lPixels(), 3)
ReDim bufR(1 To ySize, 1 To xSize)
ReDim bufG(1 To ySize, 1 To xSize)
ReDim bufB(1 To ySize, 1 To xSize)
For lCptX = 1 To xSize
For lCptY = 1 To ySize
colorBlue = lPixels(1, lCptX, lCptY)
bufB(lCptY, lCptX) = colorBlue
colorGreen = lPixels(2, lCptX, lCptY)
bufG(lCptY, lCptX) = colorGreen
colorRed = lPixels(3, lCptX, lCptY)
bufR(lCptY, lCptX) = colorRed
'色成分 不透明度 = lPixels(4, lCptX, lCptY) '無視
'ActiveSheetのセルに読み込んだ色をつけます。xl2007以降対応です。
'これを生かすととても時間がかかります。コーヒーでも飲みながら待て！
'Cells(lCptY, lCptX).Interior.Color = RGB(colorRed, colorGreen, colorBlue)
Next lCptY
Next lCptX
With Worksheets(1)
.Range(.Cells(1, 1), .Cells(ySize, xSize)).Value = bufR
End With
With Worksheets(2)
.Range(.Cells(1, 1), .Cells(ySize, xSize)).Value = bufG
End With
With Worksheets(3)
.Range(.Cells(1, 1), .Cells(ySize, xSize)).Value = bufB
End With
Set clGdip = Nothing
Application.ScreenUpdating = True
End Sub

ファイルに書き出す方もありますが、文字数制限に引っかかりましたので、ご要望が有ればアップします。

お礼

回答ありがとうございました。感激しています。

'色成分 不透明度 = lPixels(4, lCptX, lCptY)

を有効にすると、「関数が定義されていない」
というメッセージが出る以外は今のところ概ね
良好のようです。

これで、生画像の取得が出来るようになりましたが、

さらにエクスポートの方法

が判るととうれしいです。続きのコードをいただけると嬉しいです。
よろしくお願いします。

【補足】
以下、のちに見る人の参考のため補足します。

（１）Microsoft Forms 2.0 Object Libraryの出し方

通常は、
[ツール]-[マクロ]-[Visual Basic Editor]-[ツール]-[参照設定]-[Microsoft Forms 2.0 Object Library]

で出るようですが、私の環境(Excel2010)ではなかったようです。
ただ、挿入メニューからユーザーフォームを挿入すると、見つかりました。

<http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1113418901>
<http://www.moug.net/faq/viewtopic.php?t=62876>

（２）クラスモジュールのインポート法
http://officetanaka.net/excel/vba/tips/tips112c.htm

補足

【その他の補足事項】
後に見る人のために、「お礼」でつけた補足に加え、さらに補足をつけます。

(１)test1のソースで
Cells(lCptY, lCptX).Interior.Color = RGB(colorRed, colorGreen, colorBlue)

のみを有効にすると、取り込んだ画像の各ピクセルごとの色を
シート1上に表示できるようになりました。

i5を搭載するＰＣで、675 KBのBMPを用いて前記操作を行った場合、２～３秒で
所望の処理が出来ました。但し、古いＰＣだと、やはり５分程度かかるようです。

（２）当たり前のことではありますが、xlsで横方向256ピクセル以上の
画像を、test1で開こうとすると、
「実行時エラー’1004’
アプリケーション定義またはオブジェクト定義のエラーです。」
が出ます。

デバックすると、

.Range(.Cells(1, 1), .Cells(ySize, xSize)).Value = bufR

がエラーとしてひっかかりますが、要はExcelの列数制限の問題です。
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1410808914

xlsmは、セキュリティー云々に関したＭＳの責任逃れ警告
があるので、デフォルトをxlsにしている人も多いかと思いますので
ご注意ください。

尚、EXCEL2007で、「一度xls型式で作成したものを、
保存時にxlsmで保存した場合」でも、前記のエラーが出る
場合がありました。この場合は、一度xlsmファイルを終了して
Excelを再起動すれば、問題なく動作しています。ご報告まで。

（３）白黒画像(カラー画像をイルファンビューでグレースケールに変換したもの)
を、読み込んだ場合エラーになるかなと思いましたが、特に問題なく
ひらけているようです。理由はよくわかりません。

回答No.3

mitarashi

#2です。
確かにコードをこちらから貼り付け戻して実行すると再現されます。
よくよくコードを見ると、
下から8行目が、意図せずコメントアウトされてしまっているので、こちらを生かして下さい。
' clGdip.SetPixels lPixels
回答のテキストボックス内で小手直ししている際にゴミが残ってしまった様です。
悩ませてしまって申し訳ありませんでした。

お礼

以下のコードでうまくいきました（といっても言われた通りの修正をしただけですが）ありがとうございました。

Sub test2()
Dim clGdip As ClGdiPlus
Dim retBool As Boolean
Dim lPixels() As Byte
Dim lCptX As Long, lCptY As Long
Dim destfile As String
Dim ImageWidth As Long, ImageHeight As Long
Dim vntFileName As Variant
Dim pictType As String
Dim bufR As Variant, bufG As Variant, bufB As Variant
Dim targetRange As Range
Const jpegQuality As Long = 90

Set targetRange = Worksheets(1).Range("A1").CurrentRegion
ImageWidth = targetRange.Columns.Count
ImageHeight = targetRange.Rows.Count
bufR = targetRange.Value
bufG = Worksheets(2).Range(targetRange.Address).Value
bufB = Worksheets(3).Range(targetRange.Address).Value
vntFileName = _
Application.GetSaveAsFilename(InitialFileName:="Picture.jpg" _
, FileFilter:="画像ファイル,*.jpg;*.bmp;*.png" _
, FilterIndex:=1 _
, Title:="保存先の指定" _
)
If vntFileName <> False Then
Select Case StrConv(Right(vntFileName, 3), vbUpperCase)
Case "JPG"
pictType = "JPG"
Case "BMP"
pictType = "BMP"
Case "PNG"
pictType = "PNG"
Case Else
MsgBox "サポートされていない画像形式です"
Exit Sub
End Select
destfile = vntFileName
Else
Exit Sub
End If

Set clGdip = New ClGdiPlus
' 新しいビットマップを作成 幅、高さ、解像度（デフォルト96)
retBool = clGdip.CreateBitmap(ImageWidth, ImageHeight, 96)
lPixels = clGdip.GetPixels
For lCptX = 1 To UBound(lPixels(), 2)
For lCptY = 1 To UBound(lPixels(), 3)
lPixels(1, lCptX, lCptY) = bufB(lCptY, lCptX)
lPixels(2, lCptX, lCptY) = bufG(lCptY, lCptX)
lPixels(3, lCptX, lCptY) = bufR(lCptY, lCptX)
lPixels(4, lCptX, lCptY) = &HFF
Next lCptY
Next lCptX
clGdip.SetPixels lPixels
If pictType = "JPG" Then
retBool = clGdip.SaveFile(destfile, "JPG", jpegQuality)
Else
retBool = clGdip.SaveFile(destfile, pictType)
End If
Set clGdip = Nothing
End Sub

補足

教えていただいた方法、大変素晴らしいです。

２次元ＦＦＴとか、あるいは二次元データの処理とかは
Ｅｘｃｅｌで普通に出来ましたが、画像に吐き出したり
画像を取り込んだりすることについて言及した本は
知る限りないです。

是非書籍として出していただきたいぐらいの内容です。

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

回答No.2

mitarashi

#1です。ご要望に応じてファイルに書き出すコードを提示します。ご参考まで。
なお、不透明度はPNGでないと意味をなさないかと思いますが、試していません。

Sub test2()
Dim clGdip As ClGdiPlus
Dim retBool As Boolean
Dim lPixels() As Byte
Dim lCptX As Long, lCptY As Long
Dim destfile As String
Dim ImageWidth As Long, ImageHeight As Long
Dim vntFileName As Variant
Dim pictType As String
Dim bufR As Variant, bufG As Variant, bufB As Variant
Dim targetRange As Range
Const jpegQuality As Long = 90

Set targetRange = Worksheets(1).Range("A1").CurrentRegion
ImageWidth = targetRange.Columns.Count
ImageHeight = targetRange.Rows.Count
bufR = targetRange.Value
bufG = Worksheets(2).Range(targetRange.Address).Value
bufB = Worksheets(3).Range(targetRange.Address).Value
vntFileName = _
Application.GetSaveAsFilename(InitialFileName:="Picture.jpg" _
, FileFilter:="画像ファイル,*.jpg;*.bmp;*.png" _
, FilterIndex:=1 _
, Title:="保存先の指定" _
)
If vntFileName <> False Then
Select Case StrConv(Right(vntFileName, 3), vbUpperCase)
Case "JPG"
pictType = "JPG"
Case "BMP"
pictType = "BMP"
Case "PNG"
pictType = "PNG"
Case Else
MsgBox "サポートされていない画像形式です"
Exit Sub
End Select
destfile = vntFileName
Else
Exit Sub
End If

Set clGdip = New ClGdiPlus
' 新しいビットマップを作成 幅、高さ、解像度（デフォルト96)
retBool = clGdip.CreateBitmap(ImageWidth, ImageHeight, 96)
lPixels = clGdip.GetPixels
For lCptX = 1 To UBound(lPixels(), 2)
For lCptY = 1 To UBound(lPixels(), 3)
lPixels(1, lCptX, lCptY) = bufB(lCptY, lCptX)
lPixels(2, lCptX, lCptY) = bufG(lCptY, lCptX)
lPixels(3, lCptX, lCptY) = bufR(lCptY, lCptX)
lPixels(4, lCptX, lCptY) = &HFF
Next lCptY
Next lCptX
' clGdip.SetPixels lPixels
If pictType = "JPG" Then
retBool = clGdip.SaveFile(destfile, "JPG", jpegQuality)
Else
retBool = clGdip.SaveFile(destfile, pictType)
End If
Set clGdip = Nothing
End Sub

お礼

回答ありがとうございます。残念ながら、今のところトラぶっています。

画像の保存作業それ自体は、やっているようなのですが、
エクスポートされる画像は、空の画像です。

フォーマットがjpgの場合でもbmpの場合でもそうなります。

真っ黒な数キロバイトの画像が作成されます。