Excelでリサジュー曲線を描こう

　まぁ、特に理由はないんですが、Excelマクロでリサジュー曲線を描いてみました。

　普通にセルに数式を入力してグラフ描けばいいんですが、敢えてVBAでBitmap出力させてるのがポイントです。

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



Option Explicit

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 draw_bitmap()
    Dim i As Long
    Dim width As Long
    Dim height As Long
    Dim pos As Long
    Dim data() As Byte
    Dim filename As String
 
    '------------------------------
    'データの作成
    width = 256
    height = 256
 
    If width Mod 4 <> 0 Then
        MsgBox "error : width mod 4 is not zero"
        Exit Sub
    End If
 
    ReDim data(width * height * 3 - 1) As Byte
 
    For i = 0 To width * height * 3 - 1
        data(i) = CByte(255)
    Next i
 
    '------------------------------
    draw_lissajous data, width, height, 7, 11, 256
 
    '------------------------------
    filename = ThisWorkbook.Path + "\lissajous.bmp"
 
    'ファイルに書き出す
    writeBitmap filename, data, width, height
 
    'ファイルから読み込む
    readBitmap filename, data, width, height
End Sub

'Lissajouis
'x = cos( a * t)
'y = sin( b * t)
Private Sub draw_lissajous(ByRef data() As Byte, width As Long, height As Long, a As Long, b As Long, N As Long)
    Dim i As Long
    Dim x1 As Long
    Dim y1 As Long
    Dim x2 As Long
    Dim y2 As Long
 
    '------------------------------
    x1 = CLng((width - 1) * (1 + Math.Cos(a * 2 * PI * 0 / N)) / 2)
    y1 = CLng((height - 1) * (1 - Math.Sin(b * 2 * PI * 0 / N)) / 2)
     
    For i = 1 To N
        x2 = CLng((width - 1) * (1 + Math.Cos(a * 2 * PI * i / N)) / 2)
        y2 = CLng((height - 1) * (1 - Math.Sin(b * 2 * PI * i / N)) / 2)
     
        drawLine data, width, height, x1, y1, x2, y2
     
        x1 = x2
        y1 = y2
    Next i
End Sub

Private Sub drawLine(ByRef data() As Byte, width As Long, height As Long, x1 As Long, y1 As Long, x2 As Long, y2 As Long)
    Dim i As Long
    Dim N As Long
    Dim pos As Long
    Dim x As Long
    Dim y As Long
 
    '------------------------------
    N = Math.Abs(x2 - x1)
 
    If N < Math.Abs(y2 - y1) Then
        N = CLng(Math.Abs(y2 - y1))
    End If
 
    '------------------------------
    For i = 0 To N
        x = CLng(x1 + (x2 - x1) * i / N)
        y = CLng(y1 + (y2 - y1) * i / N)
     
        If 0 <= x And x < width And 0 <= y And y < height Then
            pos = (y * width + x) * 3
         
            data(pos + 0) = CByte(0)    'Blue
            data(pos + 1) = CByte(0)    'Green
            data(pos + 2) = CByte(0)    'Red
        End If
    Next i
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