Excelで画像処理をしてみました。長かった伏線を経て、ようやく本題です。
以前に公開しているBitmapと一次方程式のソースコードをコピペしておけば動作するはずです。
画像の回転とか拡大縮小とか傾けたりとかです。実は当初の目標は射影変換で、画像を傾けることでした。変換のパラメータの計算で一次方程式を解く必要があり、Gaussの消去法を使っています。
ソースコードは、ご自由にご利用ください。ただし、趣味のプログラムなので、保証はありません。
Option Explicit
Public Const PI = 3.1415926535
Public Sub Transformation_Init()
'------------------------------
Dim shp As Shape
For Each shp In Sheet1.Shapes
shp.Delete
Next
Sheet1.Cells.Delete
'------------------------------
Dim filename As String
filename = ThisWorkbook.Path + "\test.bmp"
'filename = Application.GetOpenFilename("Bitmap, *.bmp")
If filename = "False" Then Exit Sub
Sheet1.Cells(4, 6) = "Input Image"
Sheet1.Cells(5, 6).Select
ShowImage filename
'------------------------------
Dim data() As Byte
Dim width As Long
Dim height As Long
readBitmap filename, data, width, height
'------------------------------
Dim row As Long
row = 1
Sheet1.Cells(row, 1) = "Input File"
Sheet1.Cells(row, 2) = filename
Sheet1.Cells(row + 1, 1) = "Output File"
Sheet1.Cells(row + 1, 2) = ThisWorkbook.Path + "\output.bmp"
row = row + 3
Sheet1.Cells(row, 1) = "Type"
Sheet1.Cells(row, 2) = 0
'------------------------------
row = row + 2
Sheet1.Cells(row, 1) = "width_i"
Sheet1.Cells(row, 2) = width
Sheet1.Cells(row + 1, 1) = "height_i"
Sheet1.Cells(row + 1, 2) = height
Sheet1.Cells(row + 2, 1) = "width_o"
Sheet1.Cells(row + 2, 2) = width
Sheet1.Cells(row + 3, 1) = "height_o"
Sheet1.Cells(row + 3, 2) = height
'------------------------------
row = row + 5
Sheet1.Cells(row, 1) = 0
Sheet1.Cells(row, 2) = "Resize Image"
'------------------------------
row = row + 1
Sheet1.Cells(row, 1) = 1
Sheet1.Cells(row, 2) = "Rotate Image"
Sheet1.Cells(row, 3) = "angle"
Sheet1.Cells(row, 4) = 30
'------------------------------
row = row + 1
Sheet1.Cells(row, 1) = 2
Sheet1.Cells(row, 2) = "Affine Transformation"
Sheet1.Cells(row, 3) = "a0"
Sheet1.Cells(row + 1, 3) = "a1"
Sheet1.Cells(row + 2, 3) = "a2"
Sheet1.Cells(row + 3, 3) = "a3"
Sheet1.Cells(row + 4, 3) = "a4"
Sheet1.Cells(row + 5, 3) = "a5"
Sheet1.Cells(row, 4) = 1
Sheet1.Cells(row + 1, 4) = 0.8
Sheet1.Cells(row + 2, 4) = 0
Sheet1.Cells(row + 3, 4) = 0.5
Sheet1.Cells(row + 4, 4) = 1
Sheet1.Cells(row + 5, 4) = 0
'------------------------------
row = row + 6
Sheet1.Cells(row, 1) = 3
Sheet1.Cells(row, 2) = "Projective Transformation"
Sheet1.Cells(row, 3) = "xlb"
Sheet1.Cells(row + 1, 3) = "y_lb"
Sheet1.Cells(row + 2, 3) = "x_rb"
Sheet1.Cells(row + 3, 3) = "y_rb"
Sheet1.Cells(row + 4, 3) = "x_rt"
Sheet1.Cells(row + 5, 3) = "y_rt"
Sheet1.Cells(row + 6, 3) = "x_lt"
Sheet1.Cells(row + 7, 3) = "y_lt"
Sheet1.Cells(row, 4) = CLng(width / 16)
Sheet1.Cells(row + 1, 4) = CLng(height / 16)
Sheet1.Cells(row + 2, 4) = CLng(width * 15 / 16)
Sheet1.Cells(row + 3, 4) = CLng(height * 2 / 16)
Sheet1.Cells(row + 4, 4) = CLng(width * 11 / 16)
Sheet1.Cells(row + 5, 4) = CLng(height * 14 / 16)
Sheet1.Cells(row + 6, 4) = CLng(width * 3 / 16)
Sheet1.Cells(row + 7, 4) = CLng(height * 13 / 16)
'------------------------------
row = row + 8
Sheet1.Cells(row, 1) = 4
Sheet1.Cells(row, 2) = "Distort Image"
Sheet1.Cells(row, 3) = "range"
Sheet1.Cells(row + 1, 3) = "power"
Sheet1.Cells(row, 4) = 64
Sheet1.Cells(row + 1, 4) = 2
'------------------------------
End Sub
Public Sub Transformation()
'------------------------------
Dim filename As String
filename = Sheet1.Cells(1, 2)
If filename = "" Or Dir(filename) = "" Then Exit Sub
'------------------------------
Dim row As Long
Dim width_o As Long
Dim height_o As Long
Dim angle As Double
Dim a(5) As Double
Dim xo(3) As Long
Dim yo(3) As Long
Dim range As Double
Dim power As Double
row = 8
width_o = Sheet1.Cells(row, 2)
height_o = Sheet1.Cells(row + 1, 2)
row = 12
angle = Sheet1.Cells(row, 4)
row = row + 1
a(0) = Sheet1.Cells(row, 4)
a(1) = Sheet1.Cells(row + 1, 4)
a(2) = Sheet1.Cells(row + 2, 4)
a(3) = Sheet1.Cells(row + 3, 4)
a(4) = Sheet1.Cells(row + 4, 4)
a(5) = Sheet1.Cells(row + 5, 4)
row = row + 6
xo(0) = Sheet1.Cells(row, 4)
yo(0) = Sheet1.Cells(row + 1, 4)
xo(1) = Sheet1.Cells(row + 2, 4)
yo(1) = Sheet1.Cells(row + 3, 4)
xo(2) = Sheet1.Cells(row + 4, 4)
yo(2) = Sheet1.Cells(row + 5, 4)
xo(3) = Sheet1.Cells(row + 6, 4)
yo(3) = Sheet1.Cells(row + 7, 4)
row = row + 8
range = Sheet1.Cells(row, 4)
power = Sheet1.Cells(row + 1, 4)
'------------------------------
Dim data() As Byte
Dim width As Long
Dim height As Long
readBitmap filename, data, width, height
If Sheet1.Cells(4, 2) = 0 Then
ResizeImage data, width, height, width_o, height_o
ElseIf Sheet1.Cells(4, 2) = 1 Then
RotateImage data, width, height, width_o, height_o, 2 * PI * angle / 360
ElseIf Sheet1.Cells(4, 2) = 2 Then
AffineTransformation data, width, height, width_o, height_o, a
ElseIf Sheet1.Cells(4, 2) = 3 Then
ProjectiveTransformation data, width, height, width_o, height_o, xo, yo
ElseIf Sheet1.Cells(4, 2) = 4 Then
DistortImage data, width, height, width_o, height_o, range, power
End If
'------------------------------
filename = Sheet1.Cells(2, 2)
writeBitmap filename, data, width, height
Sheet1.Cells(4, 10) = "Output Image"
Sheet1.Cells(5, 10).Select
ShowImage filename
'------------------------------
End Sub
Private Sub ShowImage(filename As String)
Dim shp As Shape
Set shp = Sheet1.Shapes.AddPicture(filename, msoFalse, msoTrue, Selection.Left, Selection.Top, 0, 0)
shp.ScaleWidth 1, msoTrue
shp.ScaleHeight 1, msoTrue
shp.width = shp.width * 200 / shp.height
shp.height = 200
End Sub
Private Sub GetPixelValue(ByRef data() As Byte, ByRef width As Long, ByRef height As Long, x As Double, y As Double, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte)
Dim i As Long
Dim j As Long
Dim k As Long
Dim lineSize As Long
Dim pos As Long
Dim temp(2) As Double
lineSize = 3 * width + width Mod 4
i = Int(y)
j = Int(x)
For k = 0 To 2
'------------------------------
'No Interpolation
If 0 <= i And i < height And 0 <= j And j < width Then
pos = lineSize * i + j * 3
temp(k) = data(pos + k)
End If
'------------------------------
'Bilinear Interpolation
If 1 <= i And i < height - 1 And 1 <= j And j < width - 1 Then
pos = lineSize * i + j * 3
temp(k) = (j + 1 - x) * (i + 1 - y) * data(pos + k) _
+ (j + 1 - x) * (y - i) * data(pos + width * 3 + k) _
+ (x - j) * (i + 1 - y) * data(pos + 3 + k) _
+ (x - j) * (y - i) * data(pos + width * 3 + 3 + k)
End If
If temp(k) < 0 Then temp(k) = 0
If 255 < temp(k) Then temp(k) = 255
Next k
r = CByte(temp(2))
g = CByte(temp(1))
b = CByte(temp(0))
End Sub
' x_o = x_i * width_o / width_i
' y_o = y_i * height_o / height_i
Private Sub ResizeImage(ByRef data() As Byte, ByRef width_i As Long, ByRef height_i As Long, width_o As Long, height_o As Long)
Dim i As Long
Dim j As Long
Dim lineSize As Long
Dim pos As Long
Dim x As Double
Dim y As Double
lineSize = 3 * width_o + width_o Mod 4
Dim buf() As Byte
ReDim buf(lineSize * height_o - 1) As Byte
For i = 0 To lineSize * height_o - 1
buf(i) = 0
Next i
'------------------------------
For i = 0 To height_o - 1
For j = 0 To width_o - 1
pos = lineSize * i + j * 3
x = CDbl(j) * width_i / width_o
y = CDbl(i) * height_i / height_o
GetPixelValue data, width_i, height_i, x, y, buf(pos + 2), buf(pos + 1), buf(pos + 0)
Next j
Next i
Erase data
width_i = width_o
height_i = height_o
data = buf
End Sub
' x_o = cos * x_i - sin * y_i
' y_o = sin * x_i + cos * y_i
Private Sub RotateImage(ByRef data() As Byte, ByRef width_i As Long, ByRef height_i As Long, width_o As Long, height_o As Long, theta As Double)
Dim i As Long
Dim j As Long
Dim lineSize As Long
Dim pos As Long
Dim x As Double
Dim y As Double
lineSize = 3 * width_o + width_o Mod 4
Dim buf() As Byte
ReDim buf(lineSize * height_o - 1) As Byte
For i = 0 To lineSize * height_o - 1
buf(i) = 0
Next i
'------------------------------
Dim cos_theta As Double
Dim sin_theta As Double
cos_theta = Math.Cos(theta)
sin_theta = Math.Sin(theta)
'------------------------------
For i = 0 To height_o - 1
For j = 0 To width_o - 1
pos = lineSize * i + j * 3
x = width_i / 2 + (j - width_o / 2) * cos_theta + (i - height_o / 2) * sin_theta
y = height_i / 2 - (j - width_o / 2) * sin_theta + (i - height_o / 2) * cos_theta
GetPixelValue data, width_i, height_i, x, y, buf(pos + 2), buf(pos + 1), buf(pos + 0)
Next j
Next i
Erase data
width_i = width_o
height_i = height_o
data = buf
End Sub
' x_o = a(0) * x_i + a(1) * y_i + a(2)
' y_o = a(3) * x_i + a(4) * y_i + a(5)
Private Sub AffineTransformation(ByRef data() As Byte, ByRef width_i As Long, ByRef height_i As Long, width_o As Long, height_o As Long, a() As Double)
Dim i As Long
Dim j As Long
Dim lineSize As Long
Dim pos As Long
Dim x As Double
Dim y As Double
lineSize = 3 * width_o + width_o Mod 4
Dim buf() As Byte
ReDim buf(lineSize * height_o - 1) As Byte
For i = 0 To lineSize * height_o - 1
buf(i) = 0
Next i
'------------------------------
Dim det As Double
det = a(0) * a(4) - a(1) * a(3)
'------------------------------
For i = 0 To height_o - 1
For j = 0 To width_o - 1
pos = lineSize * i + j * 3
x = width_i / 2 + ((j - width_o / 2 - a(2)) * a(4) - (i - height_o / 2 - a(5)) * a(3)) / det
y = height_i / 2 + (-(j - width_o / 2 - a(2)) * a(1) + (i - height_o / 2 - a(5)) * a(0)) / det
GetPixelValue data, width_i, height_i, x, y, buf(pos + 2), buf(pos + 1), buf(pos + 0)
Next j
Next i
Erase data
width_i = width_o
height_i = height_o
data = buf
End Sub
' x_o = (a0 * x_i + a1 * y_i + a2) / (c0 * x_i + c1 * y_i + 1)
' y_o = (b0 * x_i + b1 * y_i + b2) / (c0 * x_i + c1 * y_i + 1)
Private Sub ProjectiveTransformation(ByRef data() As Byte, ByRef width_i As Long, ByRef height_i As Long, width_o As Long, height_o As Long, xo() As Long, yo() As Long)
Dim i As Long
Dim j As Long
Dim lineSize As Long
Dim pos As Long
Dim x As Double
Dim y As Double
lineSize = 3 * width_o + width_o Mod 4
Dim buf() As Byte
ReDim buf(lineSize * height_o - 1) As Byte
For i = 0 To lineSize * height_o - 1
buf(i) = 0
Next i
'------------------------------
Dim MatA() As Double
Dim VecX() As Double
Dim VecB() As Double
ReDim MatA(8 * 8 - 1) As Double
ReDim VecX(8 - 1) As Double
ReDim VecB(8 - 1) As Double
VecB(0) = 0
VecB(1) = 0
VecB(2) = width_i
VecB(3) = 0
VecB(4) = width_i
VecB(5) = height_i
VecB(6) = 0
VecB(7) = height_i
For i = 0 To 3
j = 2 * i
MatA(j * 8 + 0) = xo(i)
MatA(j * 8 + 1) = yo(i)
MatA(j * 8 + 2) = 1
MatA(j * 8 + 3) = 0
MatA(j * 8 + 4) = 0
MatA(j * 8 + 5) = 0
MatA(j * 8 + 6) = -xo(i) * VecB(j)
MatA(j * 8 + 7) = -yo(i) * VecB(j)
j = j + 1
MatA(j * 8 + 0) = 0
MatA(j * 8 + 1) = 0
MatA(j * 8 + 2) = 0
MatA(j * 8 + 3) = xo(i)
MatA(j * 8 + 4) = yo(i)
MatA(j * 8 + 5) = 1
MatA(j * 8 + 6) = -xo(i) * VecB(j)
MatA(j * 8 + 7) = -yo(i) * VecB(j)
Next i
MatrixSolveGauss MatA, VecX, VecB, 8
'------------------------------
For i = 0 To height_o - 1
For j = 0 To width_o - 1
pos = lineSize * i + j * 3
x = (VecX(0) * j + VecX(1) * i + VecX(2)) / (VecX(6) * j + VecX(7) * i + 1)
y = (VecX(3) * j + VecX(4) * i + VecX(5)) / (VecX(6) * j + VecX(7) * i + 1)
GetPixelValue data, width_i, height_i, x, y, buf(pos + 2), buf(pos + 1), buf(pos + 0)
Next j
Next i
Erase data
width_i = width_o
height_i = height_o
data = buf
End Sub
Private Sub DistortImage(ByRef data() As Byte, ByRef width_i As Long, ByRef height_i As Long, width_o As Long, height_o As Long, range As Double, power As Double)
Dim i As Long
Dim j As Long
Dim lineSize As Long
Dim pos As Long
Dim x As Double
Dim y As Double
lineSize = 3 * width_o + width_o Mod 4
Dim buf() As Byte
ReDim buf(lineSize * height_o - 1) As Byte
For i = 0 To lineSize * height_o - 1
buf(i) = 0
Next i
Dim temp As Double
'------------------------------
For i = 0 To height_o - 1
For j = 0 To width_o - 1
pos = lineSize * i + j * 3
temp = Math.Sqr((j - width_o / 2) * (j - width_o / 2) + (i - height_o / 2) * (i - height_o / 2))
If temp < range Then
temp = (temp / range) ^ (power - 1)
x = width_i / 2 + temp * (j - width_o / 2)
y = height_i / 2 + temp * (i - height_o / 2)
Else
x = width_i / 2 + (j - width_o / 2)
y = height_i / 2 + (i - height_o / 2)
End If
GetPixelValue data, width_i, height_i, x, y, buf(pos + 2), buf(pos + 1), buf(pos + 0)
Next j
Next i
Erase data
width_i = width_o
height_i = height_o
data = buf
End Sub
0 件のコメント:
コメントを投稿