【Excel】VBAで画像処理。画像の色調補正をする
今回は、VBAで画像のコントラスト補正をおこないます。
Excel上へ画像の展開の詳細はこの記事↓を見てください!
tsunakan97.hatenablog.com
線形な色調補正とS字を描く非線形な色調補正を行います。
線形な色調補正
a1=0.2, a2=0.8, a3=0.1, a4=0.9
横軸が元の画像の画素値で、縦軸が補正後の画素値になります。
255×a1より小さい画素値はすべて255×a3にして、255×a2より大きい画素値はすべて255×a4にします。そしてa1とa2の間は、直線でつなげて画素値とします。
'画像の線形変換!! Function ToneMapping(image() As Byte, a1 As Double, a2 As Double, a3 As Double, a4 As Double) Dim c As Long, r As Long, color As Long Dim rMax As Long, cMax As Long rMax = UBound(image, 2) cMax = UBound(image, 1) Dim image2() As Double ReDim image2(cMax, rMax, 2) For r = 0 To rMax For c = 0 To cMax For color = 0 To 2 image2(c, r, color) = image(c, r, color) / 255 Next Next Next Dim myScale As Double Dim x As Double, xNew As Double myScale = (a4 - a3) / (a2 - a1) For r = 0 To rMax For c = 0 To cMax For color = 0 To 2 x = image(c, r, color) / 255 If x < a1 Then xNew = a3 ElseIf a2 < x Then xNew = a4 Else xNew = myScale * (x - a1) + a3 End If image(c, r, color) = xNew * 255 Next Next Next End Function
非線形な色調補正
S字のカーブを作り、中心より暗い画素はより暗く、中心より明るい画素はより明るくします。メリハリがつき、はっきりとした画像になります。
今回はS字をつくるのに、正規分布の確率密度関数を積分することで得た関数を使います。
補正前後のヒストグラム(画素値の出現頻度)です。補正後のほうが山が左右に広がっており、暗い部分はより暗く、明るい部分はより明るくなっています
画素ごとに毎回計算を行っていると時間がかかるので、先に返還後の画素値を格納したルックアップテーブルを作成して、参照するようにします。
'S字のトーンカーブ(正規分布確率密度関数の積分) 'による非線形濃度変換 Function ToneMapping3(image() As Byte) Dim c As Long, r As Long, color As Long Dim x As Byte Dim rMax As Long, cMax As Long rMax = UBound(image, 2) cMax = UBound(image, 1) Dim table(255) As Double, tabledx(255) As Double, table255(255) As Byte Dim i As Long Dim a1 As Double, a2 As Double, a3 As Double, a4 As Double, myScale As Double 'tableを-3から3で正規化 '±3SDの正規分布を積分するため a1 = 0 a2 = 255 a3 = -3 a4 = 3 myScale = (a4 - a3) / (a2 - a1) For i = 0 To 255 table(i) = myScale * (i - a1) + a3 Next 'tableを正規分布の確率密度関数で計算 For i = 0 To 255 table(i) = (1 / Sqr((2 * 3.1416))) * Exp(-(table(i) ^ 2 / 2)) Next 'tableを積分してtabledxに代入 For i = 0 To 255 If i = 0 Then tabledx(i) = 0 Else tabledx(i) = tabledx(i - 1) + table(i) End If Next 'tabledxから画素値置換用のルックアップテーブルtable255を求める a1 = 0 a2 = tabledx(255) a3 = 0 a4 = 255 myScale = (a4 - a3) / (a2 - a1) For i = 0 To 255 table255(i) = CByte(myScale * (tabledx(i) - a1) + a3) Next 'image()をtable255で濃度変換 For r = 0 To rMax For c = 0 To cMax For color = 0 To 2 x = image(c, r, color) image(c, r, color) = table255(x) Next Next Next End Function
以下、全ソース。
Excelで画像の色調補正
2進化十進法を使った桁数制限のない加算器(正の整数に限る)
C言語で扱える桁数は、char型だと0~255、int型だと-32768~32767、long型だと-2147483648~2147483647までしかないです。割と少ない
2進化十進法、英語だとBCD(Binary-coded decimal)という数値の表現を使って、桁数制限のない加算器をC言語でつくったので紹介します。
2進化十進法
BCDは昔の電卓(数百万円とか時代)に用いられていた数値の表現方法です。2進数4ケタ16通りで1ケタの数値(0~9)を表現しています。16通りのうち10通りしか使わないので割と勿体なかったり...しかし、ひっ算のアルゴリズムをそのままプログラムにして数値計算ができるのでわかりやすい。
BCDで数値を表現すると次のようになります。1Byteで10進数2ケタ分格納し、配列の数だけ桁数を増やすことができます。
BCDの加算は次のように計算します。人間がひっ算で足し算をするときと同じように、下の位から順に1桁ずつ足し算を行います。
しかし、この計算には問題があって、最上位の桁が繰り上がった時に配列の外の値に書き込みをしてしまいます。
そのため、今回は、リトルエンディアンにしてから加算を行います。
リトルエンディアンは、数値をメモリに書き込む際の順番のルールです。一般的に配列の最初のほうが大きい桁で、配列の後のほうが小さい桁がになるようにイメージすることが多いと思います。リトルエンディアンはその逆で、配列の最初のほうに小さい桁、配列の後のほうに大きい桁が来るような順番で書き込みます。最上の桁が繰り上がっても配列の次の要素に書き込めばよいです。また、こうすることで配列の最初が1桁目になり、桁数のちがう数値同士の加算でも桁をそろえることができます。
以下、C言語で書いたABCDのソースコードと実行結果です。
BCDの解説では1Byteを2つに分けて2ケタ入れていましたが、今はメモリで困ることはないので、1Byte1桁で計算しています。贅沢!!
最後に、
関係ないですがBCDって字面がすごくきれいじゃないですか?。BCDの足し算はAddBCDで、ABCDになります!美しい!
【Excel】セル上にBMP画像を展開する。VBA
2週間くらい前?のホッテントリに、Excel上に画像を描く(セルを塗る)記事が載っていました。
これくらいなら自分でも作れそうだなと思ったので、VBAで実装してみます。
今回画像の展開をし、次回以降、画像処理をやる予定です(VBAで)。
はじめに
さて、VBAで画像を読み込んでセル上に展開するわけですが、VBで画像ファイルを配列化する関数を知りません。今回画像の読み込みは、BMPファイルのバイナリを読み込んで配列化しようと思います。そして、その配列をセル上に展開して画像を表示します。
バイナリで読み込めるようになれば、もうブラックボックスなんて存在しない!
BMPは、Jpegやpngと違って圧縮されていないので簡単に扱えます。
最終的にこうなります。
BMPファイルの読み込み
BMPファイルのフォーマットは以下を参照してください。
ぶっちゃけ読み込みだけを考えたときに重要となるのは、
- [10] bfOffBits 4byte
- ファイル先頭から画像データまでのオフセット[byte]
- [18] biWidth 4byte
- 画像の幅[ピクセル]
- [22] biHeight 4byte
- 画像の高さ[ピクセル]
- ファイル末尾に画像上部の画素値がある。
- 画像がひっくり返ってファイルに入っている
- 画像の行単位で、byte数が4の倍数になるように、0が追加されている
- 例えば横ピクセル数が198だったら0byteが2つ足されている
の5点です。[数値]はファイル先頭から何Byte目かを表しています。
怒られそうですが、簡単にするため、読み込むBMPファイルは、24Bit1677万色のビットマップだけとします(MSペイントで保存した場合、これになります)。
バイナリモードでファイルを読み込みます。
ChDir ThisWorkbook.Path & "\" openFileName = Application.GetOpenFilename("BMP画像,*.bmp") If openFileName = "False" Then MsgBox "BMPファイルを選択してください" Exit Sub End If 'ファイルをバイナリーモードで開き、1次元配列a()に入れる Open openFileName For Binary As #1 File_Size = LOF(1) ReDim a(File_Size) Get #1, , a() Close #1
3次元(縦×横×RGB)に配列化
ファイルの読み込みが終わったら、扱いやすいように3次元(縦×横×RGB)の配列にしていきます。
横ピクセル数が[18]から4byte、縦ピクセル数を[22]から4byteに書いてあるのでそれを取り出し、3次元(縦ピクセル×横ピクセル×3)配列image()を作成する。
そして、BMPファイルの入った1次元配列a()の末尾から順に、3次元配列image()に入れていく。
Image_Width_Pixel = myHex2Dec(a(), WIDTH_POS, WIDTH_POS + 3) Image_Height_Pixel = myHex2Dec(a(), HEIGHT_POS, HEIGHT_POS + 3) Line_Width_Size = myCalcLineSize(Image_Width_Pixel) Line_Last_Size = Line_Width_Size - Image_Width_Pixel * 3 Image_Data_Pos = myHex2Dec(a(), 10, 13) ReDim image(Image_Width_Pixel - 1, Image_Height_Pixel - 1, 3 - 1) Call WriteImage2Array(image(), a(), File_Size)
'byte列(a())を3次元配列(image(x,y,color))にいれる Function WriteImage2Array(image() As Byte,a() As Byte,fileSize As Long) Dim r As Long Dim c As Long Dim color As Long Dim rMax As Long Dim cMax As Long Dim i As Long rMax = UBound(image, 2) cMax = UBound(image, 1) i = fileSize - 1 For r = 0 To rMax For c = cMax To 0 Step -1 For color = 0 To 2 image(c, r, color) = a(i) i = i - 1 Next Next Next End Function
セル上に配列を展開
セルの幅を自動調節し、
3次元(縦ピクセル×横ピクセル×3)配列image()をA1,A2,...,B1,B2,......と順番に塗っていくことで完成!!
Function WriteArray2Cells(a() As Byte) Dim r As Long Dim c As Long Dim color As Long Dim rMax As Long Dim cMax As Long rMax = UBound(a, 2) cMax = UBound(a, 1) Application.ScreenUpdating = False For r = 0 To rMax For c = 0 To cMax Cells(r + 1, c + 1).Interior.color = RGB(a(c, r, 0), a(c, r, 1), a(c, r, 2)) Next Next Application.ScreenUpdating = True End Function
画像の保存
バイナリをいじって画像を保存するのは自信がないため、画像が展開されたセルをコピーし、MSペイントに貼り付けることで画像の保存に対応しました!!荒業
Function WriteImage2Jpeg(image() As Byte) Dim r As Long Dim c As Long r = UBound(image, 2) + 1 c = UBound(image, 1) + 1 Dim rc As Long Range(Cells(1, 1), Cells(r, c)).CopyPicture rc = Shell("mspaint", vbNormalFocus) Application.Wait Now + TimeValue("00:00:01") SendKeys "^v", True SendKeys "^s", True End Function