あの子が見ている

　コロナウイルスの感染拡大が続いています。お亡くなりになった方々のご冥福をお祈りいたします。



　コロナウイルス関連のニュースを見ていると、少し軽率なコメントを見る機会が多いように感じます。インターネット上では簡単に情報発信できるせいか、とにかく思ったことを条件反射的に書いているようなコメントです。(注)

　そういったコメントでは、「この意見が正しい」と主張するばかりで、その意見が正しい理由まで述べられていなかったりします。

　例えるなら、東京に住んでいる人が東京の都合だけ主張して、地方に住んでいる人の立場を考えていないような内容のコメントです。
　自分の立場を主張するのは間違いとは言いませんが。。。

　(逆に「私は東京に住んでいるものですが、・・・」といった前置きのあるコメントには、冷静さを感じます。)

　限られた文字数という制約や、過激な内容を好むというメディアの性質もあってか、思慮に欠けた軽率なコメントが余計に目立つ気がします。

　私が、インターネットばかり見過ぎなのでしょうか?

　思うに、子供は大人を見てその行動を真似るものです。
　そんな子供が思慮に欠いたコメントを見続けたら、どう思うでしょうか。
「大人は何も考えていない。とりあえず、自分に都合の良いことを主張することが大事。」と受け取るかもしれません。賢い子供は見抜くでしょう。

　「とにかく自分の意見を強く主張することが大事」という考え方もあるので、それを全否定する気はないのですが。。。
　見られているという意識を忘れないことも大事だと思います。

----------
(注)
2020/7/24 追記
　後から読んでみて、これ何のことだっけと思ってしまいました。国の給付金の話ですね。当時は、「いくらにしろ」とか、「条件をどうしろ」とか、「こういう政策が正解なんだよ」とか、「早くしろよバカ」とか、といった感じの話をたくさん見ました。
　後から読んでも分からない内容を条件反射的に書いてしまっている自分に反省。

相手の立場になって考えましょう

　コロナウイルスの感染防止のため、いろいろな人が意見を出しています。インターネットやテレビで連日報道されています。

　学校関係者であれば、学校の現場の問題を重視するでしょう。
　医療関係者は、医療崩壊を一番に問題視するでしょう。
　報道関係者は、みんなが注目する正しい情報を放送しようと考えているでしょう。
　経済産業省の役人なら、経済政策を優先的に考えているでしょう。
　財務省の役人なら、やみくもな財政支出は避けたいと考えるでしょう。

　ですが、みんながみんな自分の立場で意見を述べるばかりでは対立するだけです。

　お互いの立場になって考えてみて、何を優先すべきか、何を妥協すべきかを決めるべきだと思います。

　以上、小並感。

Excelで画像処理 その3

　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

Excelで画像処理 その2

　Excelで簡単な画像処理をしてみました。

　Bitmapの読み込みは"もう一度、ExcelでBitmap"のソースコードを使っています。

　グレースケール化、ガンマ値の補正、ウィンドウレベルの変更、フィルタ処理を作ってます。Bitmapが読み込めるのだから、各ピクセルの値をいじるのなんて簡単です。

　ソースコードは、ご自由にご利用ください。ただし、趣味のプログラムなので、保証はありません。



Option Explicit

Public Sub PixelProcess_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
 
    '------------------------------
    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, 6) = "Input Image"
    Sheet1.Cells(row + 1, 6).Select
    ShowImage filename
 
    '------------------------------
    Sheet1.Cells(row, 1) = "Type"
    Sheet1.Cells(row, 2) = 0
 
    '------------------------------
    row = row + 2
    Sheet1.Cells(row, 1) = 0
    Sheet1.Cells(row, 2) = "Gray Scale"
 
    '------------------------------
    row = row + 1
    Sheet1.Cells(row, 1) = 1
    Sheet1.Cells(row, 2) = "Gamma Correction"
    Sheet1.Cells(row, 3) = "gamma"
    Sheet1.Cells(row, 4) = 0.4
    '------------------------------
    row = row + 1
    Sheet1.Cells(row, 1) = 2
    Sheet1.Cells(row, 2) = "Window Level"
    Sheet1.Cells(row, 3) = "window_center"
    Sheet1.Cells(row, 4) = 128
    Sheet1.Cells(row + 1, 3) = "window_level"
    Sheet1.Cells(row + 1, 4) = 64
    '------------------------------
    row = row + 2
    Sheet1.Cells(row, 1) = 3
    Sheet1.Cells(row, 2) = "Image Filter"
    Sheet1.Cells(row + 0, 3) = "f0"
    Sheet1.Cells(row + 1, 3) = "f1"
    Sheet1.Cells(row + 2, 3) = "f2"
    Sheet1.Cells(row + 3, 3) = "f3"
    Sheet1.Cells(row + 4, 3) = "f4"
    Sheet1.Cells(row + 5, 3) = "f5"
    Sheet1.Cells(row + 6, 3) = "f6"
    Sheet1.Cells(row + 7, 3) = "f7"
    Sheet1.Cells(row + 8, 3) = "f8"
 
    Sheet1.Cells(row + 0, 4) = 0
    Sheet1.Cells(row + 1, 4) = -1
    Sheet1.Cells(row + 2, 4) = 0
    Sheet1.Cells(row + 3, 4) = -1
    Sheet1.Cells(row + 4, 4) = 4
    Sheet1.Cells(row + 5, 4) = -1
    Sheet1.Cells(row + 6, 4) = 0
    Sheet1.Cells(row + 7, 4) = -1
    Sheet1.Cells(row + 8, 4) = 0
 
    Sheet1.Cells(row + 0, 4) = 1 / 16
    Sheet1.Cells(row + 1, 4) = 2 / 16
    Sheet1.Cells(row + 2, 4) = 1 / 16
    Sheet1.Cells(row + 3, 4) = 2 / 16
    Sheet1.Cells(row + 4, 4) = 4 / 16
    Sheet1.Cells(row + 5, 4) = 2 / 16
    Sheet1.Cells(row + 6, 4) = 1 / 16
    Sheet1.Cells(row + 7, 4) = 2 / 16
    Sheet1.Cells(row + 8, 4) = 1 / 16
    '------------------------------
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

Public Sub PixelProcess()
    '------------------------------
    Dim filename As String
    filename = Sheet1.Cells(1, 2)
    If filename = "" Or Dir(filename) = "" Then Exit Sub
 
    '------------------------------
    Dim row As Long
    Dim gamma As Double
    Dim window_center  As Double
    Dim window_level As Double
    Dim f(8) As Double
 
    row = 7
    gamma = Sheet1.Cells(row, 4)
 
    row = row + 1
    window_center = Sheet1.Cells(row, 4)
    window_level = Sheet1.Cells(row + 1, 4)
 
    row = row + 2
    f(0) = Sheet1.Cells(row, 4)
    f(1) = Sheet1.Cells(row + 1, 4)
    f(2) = Sheet1.Cells(row + 2, 4)
    f(3) = Sheet1.Cells(row + 3, 4)
    f(4) = Sheet1.Cells(row + 4, 4)
    f(5) = Sheet1.Cells(row + 5, 4)
    f(6) = Sheet1.Cells(row + 6, 4)
    f(7) = Sheet1.Cells(row + 7, 4)
    f(8) = Sheet1.Cells(row + 8, 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
        GrayScale data, width, height
    ElseIf Sheet1.Cells(4, 2) = 1 Then
        GammaCorrection data, width, height, gamma
    ElseIf Sheet1.Cells(4, 2) = 2 Then
        WindowLevel data, width, height, window_center, window_level
    ElseIf Sheet1.Cells(4, 2) = 3 Then
        ImageFilter data, width, height, f
    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 GrayScale(ByRef data() As Byte, ByRef width As Long, ByRef height As Long)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lineSize As Long
    Dim pos As Long
 
    lineSize = 3 * width + width Mod 4
 
    Dim temp As Double
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = lineSize * i + j * 3
         
            temp = 0.2989 * data(pos + 2) + 0.587 * data(pos + 1) + 0.114 * data(pos + 0)
         
            If temp < 0 Then temp = 0
            If 255 < temp Then temp = 255
         
            For k = 0 To 2
                data(pos + k) = CByte(temp)
            Next k
        Next j
    Next i
End Sub

Private Sub GammaCorrection(ByRef data() As Byte, ByRef width As Long, ByRef height As Long, gamma As Double)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lineSize As Long
    Dim pos As Long
 
    lineSize = 3 * width + width Mod 4
 
    Dim temp As Double
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = lineSize * i + j * 3
         
            For k = 0 To 2
                temp = 255 * (CDbl(data(pos + k)) / 255) ^ gamma
             
                If temp < 0 Then temp = 0
                If 255 < temp Then temp = 255
         
                data(pos + k) = CByte(temp)
            Next k
        Next j
    Next i
End Sub

Private Sub WindowLevel(ByRef data() As Byte, ByRef width As Long, ByRef height As Long, window_center As Double, window_level As Double)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lineSize As Long
    Dim pos As Long
 
    lineSize = 3 * width + width Mod 4
 
    Dim temp As Double
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = lineSize * i + j * 3
         
            For k = 0 To 2
                temp = CDbl(255) / window_level * (CDbl(data(pos + k)) - window_center + window_level / 2)
         
                If temp < 0 Then temp = 0
                If 255 < temp Then temp = 255
         
                data(pos + k) = CByte(temp)
            Next k
        Next j
    Next i
End Sub

'f6 f7 f8
'f3 f4 f5
'f0 f1 f2
Private Sub ImageFilter(ByRef data() As Byte, ByRef width As Long, ByRef height As Long, f() As Double)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lineSize As Long
    Dim pos As Long
 
    lineSize = 3 * width + width Mod 4
 
    Dim buf() As Byte
    ReDim buf(lineSize * height - 1) As Byte
 
    For i = 0 To lineSize * height - 1
        buf(i) = 0
    Next i
 
    Dim temp As Double
 
    '------------------------------
    For i = 1 To height - 2
        For j = 1 To width - 2
            pos = lineSize * i + j * 3
         
            For k = 0 To 2
                temp = f(0) * CDbl(data(pos + lineSize - 3 + k)) _
                    + f(1) * CDbl(data(pos + lineSize + k)) _
                    + f(2) * CDbl(data(pos + lineSize + 3 + k)) _
                    + f(3) * CDbl(data(pos - 3 + k)) _
                    + f(4) * CDbl(data(pos + k)) _
                    + f(5) * CDbl(data(pos + 3 + k)) _
                    + f(6) * CDbl(data(pos - lineSize - 3 + k)) _
                    + f(7) * CDbl(data(pos - lineSize + k)) _
                    + f(8) * CDbl(data(pos + lineSize + 3 + k))
             
                If temp < 0 Then temp = 0
                If 255 < temp Then temp = 255
     
                buf(pos + k) = CByte(temp)
            Next k
        Next j
    Next i
 
    '------------------------------
    Erase data
    data = buf
End Sub

Excelで画像処理 その1

　ExcelでBitmap画像のヒストグラムを調べるプログラムを作りました。

　Bitmapの読み込みは"もう一度、ExcelでBitmap"のソースコードを使っています。画像処理をするための布石です。

　ソースコードは、ご自由にご利用ください。ただし、趣味のプログラムなので、保証はありません。


Option Explicit

Public Sub histogram()
    '------------------------------
    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
 
    '------------------------------
    Dim data() As Byte
    Dim width As Long
    Dim height As Long
 
    Dim i As Long
    Dim j As Long
    Dim lineSize As Long
    Dim pos As Long
 
    Dim hr(255) As Long
    Dim hg(255) As Long
    Dim hb(255) As Long
 
    readBitmap filename, data, width, height
 
    lineSize = 3 * width + width Mod 4
 
    For i = 0 To 255
        hr(i) = 0
        hg(i) = 0
        hb(i) = 0
    Next i
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = lineSize * i + j * 3
         
            hb(data(pos + 0)) = hb(data(pos + 0)) + 1
            hg(data(pos + 1)) = hg(data(pos + 1)) + 1
            hr(data(pos + 2)) = hr(data(pos + 2)) + 1
        Next j
    Next i
 
    '------------------------------
    Sheet1.Cells(1, 1) = "Input File"
    Sheet1.Cells(1, 2) = filename
 
    '------------------------------
    Sheet1.Cells(2, 1) = "width"
    Sheet1.Cells(3, 1) = "height"
    Sheet1.Cells(2, 2) = width
    Sheet1.Cells(3, 2) = height
 
    '------------------------------
    Sheet1.Cells(5, 1) = "Input Image"
    Sheet1.Cells(6, 1).Select
 
    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
 
    '------------------------------
    Sheet1.Cells(22, 1) = "Histogram"
    Sheet1.Cells(22, 2) = "r"
    Sheet1.Cells(22, 3) = "g"
    Sheet1.Cells(22, 4) = "b"
 
    For i = LBound(hr) To UBound(hr)
        Sheet1.Cells(23 + i, 1) = i
        Sheet1.Cells(23 + i, 2) = hr(i)
        Sheet1.Cells(23 + i, 3) = hg(i)
        Sheet1.Cells(23 + i, 4) = hb(i)
    Next i
 
    '------------------------------
End Sub

Excelで一次方程式

　Excelで一次方程式を解くプログラムを作りました。

　最初、LU分解を作ったのですが、使ってみたら、Pivot選択してないから、全然実用にならなくて。で、普通にGaussの消去法を作りました。
　おまけで、反復法のプログラムも作成しています。反復法も使える問題が限られるので、扱いは少し難しいですね。

　なお、このプログラムは画像処理をやるときの伏線です。

　ソースコードは、ご自由にご利用ください。ただし、趣味のプログラムなので、保証はありません。




Option Explicit

Public Const MINIMUM_VALUE As Double = 0.000001
Public Const MAX_ITERATION  As Long = 100

Dim row As Long '結果を表示する行の位置

'LU分解のサンプル
Public Sub matrix_test_LU()
    Dim i As Long
    Dim j As Long
 
    'A x = b
    Dim N As Long
    Dim MatA() As Double
    Dim VecX() As Double
    Dim VecB() As Double
 
    '------------------------------
    'Initialize
    N = 4
 
    ReDim MatA(N * N - 1) As Double
    ReDim VecX(N - 1) As Double
    ReDim VecB(N - 1) As Double
 
    For i = 0 To N - 1
        For j = 0 To N - 1
            MatA(i * N + j) = (1 + i) ^ j
        Next j
     
        VecB(i) = 0
    Next i
 
    VecB(0) = 1
 
    '------------------------------
    'Calculation
    Dim MatLU() As Double
 
    MatrixLU MatA, MatLU, N
    MatrixSolveLU MatA, VecX, VecB, N
 
    '------------------------------
    'Output
    Sheet1.Cells.Clear
 
    row = 1
 
    show_ABX MatA, VecB, VecX, N
 
    Sheet1.Cells(row, 1) = "LU"
    For i = 0 To N - 1
        For j = 0 To i - 1
            Sheet1.Cells(row + i, 2 + j) = MatLU(i * N + j)
        Next j
     
        Sheet1.Cells(row + i, 2 + i) = 1
     
        For j = i To N - 1
            Sheet1.Cells(row + i, 2 + N + j) = MatLU(i * N + j)
        Next j
    Next i
 
    '------------------------------
End Sub

'Gaussの消去法のサンプル
Public Sub matrix_test_Gauss()
    Dim i As Long
    Dim j As Long
 
    'A x = b
    Dim N As Long
    Dim MatA() As Double
    Dim VecX() As Double
    Dim VecB() As Double
 
    '------------------------------
    'Initialize
    N = 5
 
    ReDim MatA(N * N - 1) As Double
    ReDim VecX(N - 1) As Double
    ReDim VecB(N - 1) As Double
 
    For i = 0 To N - 1
        For j = 0 To N - 1
            MatA(i * N + j) = (i + j + 1) Mod N
        Next j
     
        VecB(i) = 0
    Next i
 
    VecB(0) = 1
 
    '------------------------------
    'Calculation
    Dim MatG() As Double
    Dim MatT() As Double
 
    MatrixGauss MatA, MatG, MatT, N
    MatrixSolveGauss MatA, VecX, VecB, N
 
    '------------------------------
    'Output
    Sheet1.Cells.Clear
 
    row = 1
 
    show_ABX MatA, VecB, VecX, N
 
    Sheet1.Cells(row, 1) = "T, A, G"
    For i = 0 To N - 1
        For j = 0 To N - 1
            Sheet1.Cells(row + i, 2 + j) = MatT(i * N + j)
            Sheet1.Cells(row + i, 2 + N + j) = MatA(i * N + j)
            Sheet1.Cells(row + i, 2 + 2 * N + j) = MatG(i * N + j)
        Next j
    Next i
 
    '------------------------------
End Sub

'反復法のサンプル
'参考 <http://nkl.cc.u-tokyo.ac.jp/13n/SolverIterative.pdf>
Public Sub matrix_test_iteration()
    Dim i As Long
    Dim j As Long
 
    'A x = b
    Dim N As Long
    Dim MatA() As Double
    Dim VecX() As Double
    Dim VecB() As Double
 
    '------------------------------
    'Initialize
    N = 3
 
    ReDim MatA(N * N - 1) As Double
    ReDim VecX(N - 1) As Double
    ReDim VecB(N - 1) As Double
 
    For i = 0 To N - 1
        For j = 0 To N - 1
            MatA(i * N + j) = 1
        Next j
     
        MatA(i * N + i) = 10
        VecB(i) = 0
    Next i
 
    VecB(0) = 1
 
    '------------------------------
    'Calculation
    MatrixSolveIteration MatA, VecX, VecB, N
 
    '------------------------------
    'Output
    Sheet1.Cells.Clear
 
    row = 1
 
    show_ABX MatA, VecB, VecX, N
 
End Sub

'行列の表示
Public Sub show_ABX(MatA() As Double, VecB() As Double, VecX() As Double, N As Long)
    Dim i As Long
    Dim j As Long
 
    Sheet1.Cells(row, 1) = "A"
    For i = 0 To N - 1
        For j = 0 To N - 1
            Sheet1.Cells(row + i, 2 + j) = MatA(i * N + j)
        Next j
    Next i
 
    row = row + N
 
    Sheet1.Cells(row, 1) = "B"
    For i = 0 To N - 1
        Sheet1.Cells(row + i, 2) = VecB(i)
    Next i
    row = row + N
 
    Sheet1.Cells(row, 1) = "X"
    For i = 0 To N - 1
        Sheet1.Cells(row + i, 2) = VecX(i)
    Next i
 
    row = row + N
End Sub

'LU分解
'A = L * U
Public Sub MatrixLU(MatA() As Double, ByRef MatLU() As Double, N As Long)
    Dim i As Long
    Dim j As Long
    Dim k As Long
 
    ReDim MatLU(N * N - 1) As Double
 
    '------------------------------
    For i = 0 To N - 1
        For j = 0 To N - 1
            MatLU(i * N + j) = MatA(i * N + j)
        Next j
    Next i
 
    '------------------------------
    For i = 0 To N - 1
        For j = 0 To i - 1
            For k = 0 To j - 1
                MatLU(i * N + j) = MatLU(i * N + j) - MatLU(i * N + k) * MatLU(k * N + j)
            Next k
         
            If Math.Abs(MatLU(j * N + j)) < MINIMUM_VALUE Then GoTo Label1
         
            MatLU(i * N + j) = MatLU(i * N + j) / MatLU(j * N + j)
        Next j
     
        For j = i To N - 1
            For k = 0 To i - 1
                MatLU(i * N + j) = MatLU(i * N + j) - MatLU(i * N + k) * MatLU(k * N + j)
            Next k
        Next j
    Next i
 
    '------------------------------
    Exit Sub
 
Label1:
    MsgBox "Divided by Zero"
End Sub

'LU分解
'B = A * X = L * U * X
Public Sub MatrixSolveLU(MatA() As Double, ByRef VecX() As Double, VecB() As Double, N As Long)
    Dim i As Long
    Dim j As Long
 
    Dim MatLU() As Double
    ReDim MatLU(N * N - 1) As Double
    ReDim VecX(N - 1) As Double
 
    MatrixLU MatA, MatLU, N
 
    '------------------------------
    For i = 0 To N - 1
        VecX(i) = VecB(i)
     
        For j = 0 To i - 1
            VecX(i) = VecX(i) - MatLU(i * N + j) * VecX(j)
        Next j
    Next i
 
    '------------------------------
    For i = N - 1 To 0 Step -1
        For j = i + 1 To N - 1
            VecX(i) = VecX(i) - MatLU(i * N + j) * VecX(j)
        Next j
     
        If Math.Abs(MatLU(i * N + i)) < MINIMUM_VALUE Then GoTo Label1
         
        VecX(i) = VecX(i) / MatLU(i * N + i)
    Next i
 
    '------------------------------
    Exit Sub
 
Label1:
    MsgBox "Divided by Zero"
End Sub

'Gaussの消去法
'T * A = G
Public Sub MatrixGauss(MatA() As Double, ByRef MatG() As Double, ByRef MatT() As Double, N As Long)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim temp As Double
 
    ReDim MatG(N * N - 1) As Double
    ReDim MatT(N * N - 1) As Double
 
    '------------------------------
    For i = 0 To N - 1
        For j = 0 To N - 1
            MatG(i * N + j) = MatA(i * N + j)
            MatT(i * N + j) = 0
        Next j
     
        MatT(i * N + i) = 1
    Next i
 
    '------------------------------
    For i = 0 To N - 1
        'find pivot
        k = i
     
        For j = i + 1 To N - 1
            If Math.Abs(MatG(k * N + i)) < Math.Abs(MatG(j * N + i)) Then
                k = j
            End If
        Next j
     
        'row switching
        For j = 0 To N - 1
            temp = MatG(i * N + j)
            MatG(i * N + j) = MatG(k * N + j)
            MatG(k * N + j) = temp
         
            temp = MatT(i * N + j)
            MatT(i * N + j) = MatT(k * N + j)
            MatT(k * N + j) = temp
        Next j
     
        'row multiplication
        If Math.Abs(MatG(i * N + i)) < 0.000001 Then GoTo Label1
     
        temp = 1 / MatG(i * N + i)
     
        For j = 0 To N - 1
            MatG(i * N + j) = temp * MatG(i * N + j)
            MatT(i * N + j) = temp * MatT(i * N + j)
        Next j
     
        'row addition
        For j = i + 1 To N - 1
            temp = MatG(j * N + i)
         
            For k = 0 To N - 1
                MatG(j * N + k) = MatG(j * N + k) - temp * MatG(i * N + k)
                MatT(j * N + k) = MatT(j * N + k) - temp * MatT(i * N + k)
            Next k
        Next j
    Next i
 
    '------------------------------
    Exit Sub
 
Label1:
    MsgBox "Divided by Zero"
End Sub

'Gaussの消去法
'T * B = T * A * X = G * X
Public Sub MatrixSolveGauss(MatA() As Double, ByRef VecX() As Double, VecB() As Double, N As Long)
    Dim i As Long
    Dim j As Long
 
    Dim MatG() As Double
    Dim MatT() As Double
    ReDim MatG(N * N - 1) As Double
    ReDim MatT(N * N - 1) As Double
    ReDim VecX(N - 1) As Double
 
    MatrixGauss MatA, MatG, MatT, N
 
    '------------------------------
    For i = 0 To N - 1
        VecX(i) = 0
     
        For j = 0 To N - 1
            VecX(i) = VecX(i) + MatT(i * N + j) * VecB(j)
        Next j
    Next i
 
    '------------------------------
    For i = N - 1 To 0 Step -1
        For j = i + 1 To N - 1
            VecX(i) = VecX(i) - MatG(i * N + j) * VecX(j)
        Next j
     
        If Math.Abs(MatG(i * N + i)) < 0.000001 Then GoTo Label1
     
        VecX(i) = VecX(i) / MatG(i * N + i)
    Next i
 
    '------------------------------
    Exit Sub
 
Label1:
    MsgBox "Divided by Zero"
End Sub

'反復法
'B = A * X = ( L + D + U) * X
'X = D^-1 * ( B - L * X - U * X)
'Jacobi         : X_i+1 = D^-1 * ( B - L * X_i - U * X_i)
'Gauss-Seidel   : X_i+1 = D^-1 * ( B - L * X_i+1 - U * X_i)
'epsilon = ( B - A * X_i) * ( B - A * X_i) / ( B * B)
'        = ( D * ( X_i+1 - X_i)) * ( D * ( X_i+1 - X_i)) / ( B * B) (for Jacobi)
Public Sub MatrixSolveIteration(MatA() As Double, ByRef VecX() As Double, VecB() As Double, N As Long)
    Dim i As Long
    Dim j As Long
    Dim k As Long
 
    Dim VecY() As Double
 
    ReDim VecX(N - 1) As Double
    ReDim VecY(N - 1) As Double
 
    Dim epsilon As Double
    Dim b2 As Double
 
    '------------------------------
    '収束性の確認
    For i = 0 To N - 1
        epsilon = Math.Abs(MatA(i * N + i))
     
        For j = 0 To i - 1
            epsilon = epsilon - Math.Abs(MatA(i * N + j))
        Next j
     
        For j = i + 1 To N - 1
            epsilon = epsilon - Math.Abs(MatA(i * N + j))
        Next j
     
        If epsilon < 0 Then
            MsgBox "It's not convergent."
            Exit Sub
        End If
    Next i
 
    '------------------------------
    For i = 0 To N - 1
        If Math.Abs(MatA(i * N + i)) < MINIMUM_VALUE Then GoTo Label1
    Next i
 
    '------------------------------
    b2 = 0
 
    For i = 0 To N - 1
        b2 = b2 + VecB(i) * VecB(i)
    Next i
 
    If b2 < MINIMUM_VALUE Then GoTo Label1
 
    '------------------------------
    '反復法の初期値
    For i = 0 To N - 1
        VecX(i) = VecB(i)
    Next i
 
    '------------------------------
    For i = 0 To MAX_ITERATION - 1
        For j = 0 To N - 1
            VecY(j) = VecB(j)
         
            For k = 0 To j - 1
                'Jacobi method
                'VecY(j) = VecY(j) - MatA(j * N + k) * VecX(k)
             
                'Gauss-Seidel method
                VecY(j) = VecY(j) - MatA(j * N + k) * VecY(k)
            Next k
         
            For k = j + 1 To N - 1
                VecY(j) = VecY(j) - MatA(j * N + k) * VecX(k)
            Next k
         
            VecY(j) = VecY(j) / MatA(j * N + j)
        Next j
     
        '------------------------------
        '収束の判定
        epsilon = 0
     
        For j = 0 To N - 1
            epsilon = epsilon + (MatA(j * N + j) * (VecY(j) - VecX(j))) ^ 2
        Next j
     
        epsilon = Math.Sqr(epsilon / b2)
     
        If epsilon < MINIMUM_VALUE Then
            MsgBox "converge : " + CStr(i)
            Exit Sub
        End If
     
        '------------------------------
        For j = 0 To N - 1
            VecX(j) = VecY(j)
        Next j
     
        '------------------------------
    Next i

    '------------------------------
    Exit Sub

Label1:
    MsgBox "Divided by Zero"
End Sub

もう一度、ExcelでBitmap

　以前、Excel VBAでBitmap画像を作るプログラムを作りました。お気づきの方?もいるかもしれませんが、以前のプログラムでは画像の幅が4の倍数のみしか扱えません。
　理由はめんどくさかったからです。

　今回、画像処理でもして遊ぼうかなぁと思ったんですが、いろいろな画像で遊ぶために、4の倍数でない画像の幅にも対応させました。まぁ、ほんとにちょっといじっただけなんですけど。

　ソースコードは、ご自由にご利用ください。ただし、趣味のプログラムなので、保証はありません。




Option Explicit

'--------------------------------------------------
'Bitmapファイルの構造
'<BITMAPFILEHEADER構造体> + <BITMAPINFOHEADER構造体> + <カラーパレット> + <画像データ>
'--------------------------------------------------
'<BITMAPFILEHEADER構造体>
'bfType         2bytes  "BM"
'bfSize         4bytes  ファイルサイズ, byte単位
'bfReserved1    2bytes  予約領域
'bfReserved2    2bytes  予約領域
'bfOffBits      4bytes  ファイル先頭から画像データまでのオフセット, byte単位
'--------------------------------------------------
'<BITMAPINFOHEADER構造体>
'biSize         4bytes  BITMAPINFOHEADERのサイズ
'biWidth        4bytes  画像の幅, pixel単位
'biHeight       4bytes  画像の高さ, pixel単位
'biPlanes       2bytes  プレーン数, 常に1
'biBitCount     2bytes  1画素当たりのデータサイズ, 1,4,8,24,32bitのいずれか
'biCompression  4bytes  圧縮形式, 無圧縮なら0
'biSizeImage    4bytes  画像データ部のサイズ, 0でもOK
'biXPixPerMeter 4bytes  横方向解像度, 1m当たりの画素数, 0でもOK
'biYPixPerMeter 4bytes  縦方向解像度, 1m当たりの画素数, 0でもOK
'biClrUsed      4bytes  格納されているパレット数, 0でもOK
'biClrImportant 4bytes  重要なパレットのインデックス, 0でもOK
'--------------------------------------------------
'<カラーパレット>
'1, 4, 8bitカラーの場合はカラーパレットのRGB値
'24, 32bitカラーの場合はない
'--------------------------------------------------
'<画像データ>
'1, 4, 8bitカラーの場合は、カラーパレットの値
'24, 32bitカラーの場合は、RGB値の配列
'画像の1ラインのデータ長は4の倍数byteじゃないとダメ (biWidth * biBitCount / 8 が 4の倍数)
'24bitカラーの場合、1ラインのデータ長(byte単位)は 3 * width + width mod 4 とすれば、とりあえずOK
'--------------------------------------------------

Public Const PI = 3.1415926535

'<BITMAPFILEHEADER構造体>
Private Type BITMAP_FILE_HEADER
    bfType As String * 2
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private bfHeader As BITMAP_FILE_HEADER

'<BITMAPINFOHEADER構造体>
Private Type BITMAP_INFO_HEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPixPerMeter As Long
    biYPixPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private biHeader As BITMAP_INFO_HEADER

Public Sub bitmap_test()
    Dim i As Long
    Dim j As Long
    Dim width As Long
    Dim height As Long
    Dim lineSize As Long
    Dim pos As Long
    Dim data() As Byte
    Dim filename As String
 
    '------------------------------
    'データの作成
    width = 127
    height = 128
    lineSize = 3 * width + width Mod 4
    ReDim data(lineSize * height - 1) As Byte
 
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = lineSize * i + j * 3
            data(pos + 0) = CByte(255 / width * j)  'Blue
            data(pos + 1) = CByte(255 / height * i) 'Green
            data(pos + 2) = CByte(255 - 127 / width * j - 127 / height * i) 'Red
         
            If j Mod 8 = 0 Or i Mod 8 = 0 Then
                data(pos + 0) = 0
                data(pos + 1) = 0
                data(pos + 2) = 255
            End If
        Next j
     
    Next i
 
    '------------------------------
 
    filename = ThisWorkbook.Path + "\test.bmp"
 
    'ファイルに書き出す
    writeBitmap filename, data, width, height
 
    'ファイルから読み込む
    readBitmap filename, data, width, height
End Sub

'Bitmapファイルの書き出し
'24bitフルカラーのみ対応
Public Sub writeBitmap(filename As String, data() As Byte, width As Long, height As Long)

    '1ラインのデータ長(byte単位)は、4の倍数でないとダメ
    If UBound(data) <> (3 * width + width Mod 4) * height - 1 Then GoTo Label1
 
    bfHeader.bfType = "BM"
    bfHeader.bfSize = UBound(data) + 1 + 54
    bfHeader.bfReserved1 = 0
    bfHeader.bfReserved2 = 0
    bfHeader.bfOffBits = 54
 
    biHeader.biSize = 40
    biHeader.biWidth = width
    biHeader.biHeight = height
    biHeader.biPlanes = 1
    biHeader.biBitCount = 24
    biHeader.biCompression = 0
    biHeader.biSizeImage = UBound(data) + 1
    biHeader.biXPixPerMeter = 0
    biHeader.biYPixPerMeter = 0
    biHeader.biClrUsed = 0
    biHeader.biClrImportant = 0
 
    On Error GoTo Label1
 
    Open filename For Binary As 1
        Put 1, , bfHeader
        Put 1, , biHeader
        Put 1, , data
    Close 1
 
    Exit Sub
 
Label1:
    Close 1
    MsgBox "Error (writeBitmap)", vbExclamation
End Sub

'Bitmapファイルの読み込み
'24bitフルカラーのみ対応
Public Sub readBitmap(filename As String, ByRef data() As Byte, ByRef width As Long, ByRef height As Long)
    On Error GoTo Label1
 
    Open filename For Binary As 1
        Get 1, , bfHeader
        If bfHeader.bfType <> "BM" Then GoTo Label1
     
        Get 1, , biHeader
        If biHeader.biSize <> 40 Then GoTo Label1
        If biHeader.biBitCount <> 24 Then GoTo Label1
     
        ReDim data(bfHeader.bfSize - bfHeader.bfOffBits - 1) As Byte
        Get 1, , data

        width = biHeader.biWidth
        height = biHeader.biHeight
    Close 1
 
    '1ラインのデータ長(byte単位)は、4の倍数でないとダメ
    If UBound(data) <> (3 * width + width Mod 4) * height - 1 Then GoTo Label1
 
    Exit Sub
 
Label1:
    Close 1
    MsgBox "Error (readBitmap)", vbExclamation
End Sub

火災報知器が鳴ったら

　私が住んでいるアパートで火災報知器が鳴りました。怖いですね。

　アパート全体で警報が鳴ったのですが、煙が出ているわけでもないので、どこが原因かはまったく分かりません。少なくとも自分の部屋には異常がないことを確認しましたが、ほかの部屋は、人がいるかすら分からないです。
　逃げる準備と周囲の警戒くらいしかできなかったです。

　結局、誤報だったみたいで、何事もなかったんですが。
・・・ていうか、誤報でしたという連絡は来ていないので、何にも分からず仕舞です。

　普段、自分が火事を起こさないようには気を付けていますが、他人が起こした火事に巻き込まれた場合をあまり想定していなかったことに気づかされました。

　気を付けましょう。

スマホが苦手

　一応、現代人なんでスマホを使っていますが、すっごく苦手です。電車に乗るとみんながスマホをいじっているので、私からするとびっくりです。

　スマホって使いにくくないでしょうか？

　ちょっとニュースを見たいだけなんですが、スクロールしようとしたら、どこかのリンクがクリックされて、リンク先に飛ばされるなんてことがよくあります。
　イライラします。

　最近はニュース動画や広告動画も多いらしく、表示に時間がかかります。勝手にリンク先に移動しようとして、しかも動画で重たくて、戻るって押してもなかなか反応しなかったりします。で、何回も戻ろうとしたら、今度は戻りすぎちゃうわけです。
　イライラします。

　見る気もない動画が勝手にダウンロードされ始めて、気が付いたらデータ通信量があっという間に増えていたり。
　ほんとイライラします。

　私が使っているスマホが古いからでしょうか。
　私が、ITについていけないおっさんだからでしょうか。(^_^;)

　最近は5Gとやらが話題になっています。なんでも大量のデータを高速に通信できるとか。ますます重たいサイトが増えそうで嫌になります。データ量が少ない方が価値があると思う人は少ないんでしょうか。残念です。

　もういっそデータ通信量に応じて税金でもかけてほしいです。電気・ガス・水道なんかと同じく、データ通信量の節約も悪いことではないと思うんです。

横領するココロ

　普通の会社員が会社のお金を数億円単位で横領するなんて事件がたまにあります。数万円ならまだしも数億円という規模はなかなか巨額です。会社への恨みとかストレス発散とか、動機は多々あるのでしょうが、私にはそんな高額を動かす度胸はないです。

　どうしてそんな大胆なことができるのかと不思議に思っていたのですが、なるほどと思える理由を知りました。

　実は横領することで、会社に利益があるという理屈があるんです。そのカラクリは税金です。

　税金の細かい計算は難しいですが、会社の経費が多ければその分税金が減るということがあるようです。極端な話、経営が黒字でも経費を偽って赤字でしたと言い張れば、日本では法人税は払わなくてよくなります。

　"税金が減る分、会社が得するんだから"という考えが裏にあって、無駄な経費を自分の懐へ、という感じです。納得です。

　もう少し考えてみると、この場合、会社が納める税金が減るのだから、国民が被害を受けているわけです。

　節税なんて言葉がありますが、税金をきちんと払うのは大事なことです。日本では納税の義務があまり重視されていない気がします。

　まぁ、あからさまに税金を無駄遣いされるのは大変癪なんですが。

共感を見つけて

　Yahoo Newsを見ていたら、私が以前書いたコラムと似た意見の記事を見つけました。おそらくリンク先はすぐになくなってしまうと思うので、ちょっとだけ引用させていただきます。

<https://headlines.yahoo.co.jp/article?a=20200331-00340525-toyo-bus_all&p=6>

"しかしネットの債務で見ても日本の水準は国際的に見て高い。そして、それが毎年増え続けていることが問題です。"

　私の考えなんて誰かの意見の寄せ集めだと思うのですが、私と似た意見には久しく出会わなかったので、意外でした。

　自分が正しいと思っていることを、他の誰かも同じく正しいと思っているとわかると、やっぱりうれしいですね。安心します。

反りが合わない

　新幹線やら飛行機やらで長時間移動することがあるのですが、気づいたことがあります。

　イスの反りが合わないんです。

　正しい姿勢では人間の背筋はS字カーブになります。腰からおなかにかけては前に出て、肩のあたりが後ろ出ます。

　多くの座席のイスの背もたれの反りは、ただ凹んでいるだけの気がします。三日月のような形です。少なくともS字にはなっていません。

　きっと背筋と反りが合わないから、長時間座っていると疲れるんです。たぶん。

　もちろん、世の中にはいろいろな身長、体形の人がいるし、座席の形状も非常に考えて作られているとは思うのですが。。。
　快適な旅路を求めて、研究中です (^o^)