Excelでボロノイ図を描こう

　ちょっと興味があったので、Excelでボロノイ図を描いてみました。

　真面目にボロノイ図を描くアルゴリズムはなかなかに難しいです。というわけで、お手軽な方法を使っています。
　データ点を対称に配置するときれいな模様ができますね。

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



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 bitmap_voronoi()
    Dim i As Long
    Dim width As Long
    Dim height As Long
    Dim data() As Byte
    Dim filename As String
 
    Dim N As Long
    Dim px() As Long
    Dim py() As Long
 
    '------------------------------
    width = 128
    height = 128
    ReDim data(width * height * 3 - 1) As Byte
 
    '------------------------------
    '適当なデータの作成
    N = 64
    ReDim px(N - 1) As Long
    ReDim py(N - 1) As Long
 
'    For i = 0 To N - 1
'        px(i) = CLng((width - 1) * Math.Rnd())
'        py(i) = CLng((height - 1) * Math.Rnd())
'    Next i
 
    For i = 0 To N - 1
        px(i) = CLng((width - 1) * (1 + Math.Cos(7 * 2 * PI * i / N)) / 2)
        py(i) = CLng((height - 1) * (1 - Math.Sin(5 * 2 * PI * i / N)) / 2)
    Next i

    '------------------------------
    draw_voronoi data, width, height, px, py, N
 
    '------------------------------
    filename = ThisWorkbook.Path + "\voronoi.bmp"
 
    'ファイルに書き出す
    writeBitmap filename, data, width, height
 
    'ファイルから読み込む
    readBitmap filename, data, width, height
End Sub

Private Sub draw_voronoi(ByRef data() As Byte, width As Long, height As Long, px() As Long, py() As Long, N As Long)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim pos As Long
 
    Dim id() As Long
    Dim temp1 As Double
    Dim temp2 As Double
 
    '------------------------------
    ReDim id(width * height - 1) As Long
     
    For i = 0 To height - 1
        For j = 0 To width - 1
            id(i * width + j) = 0
            temp1 = (px(0) - j) * (px(0) - j) + (py(0) - i) * (py(0) - i)
         
            For k = 0 To N - 1
                temp2 = (px(k) - j) * (px(k) - j) + (py(k) - i) * (py(k) - i)
             
                If temp2 < temp1 Then
                    id(i * width + j) = k
                    temp1 = temp2
                End If
            Next k
        Next j
    Next i
 
    '------------------------------
    For i = 0 To height - 1
        For j = 0 To width - 1
            pos = (width * i + j) * 3
            data(pos + 0) = CByte(0)
            data(pos + 1) = CByte(255 * id(i * width + j) / N)
            data(pos + 2) = CByte(0)
        Next j
    Next i
 
    For i = 0 To N - 1
        pos = (width * py(i) + px(i)) * 3
        data(pos + 0) = CByte(0)
        data(pos + 1) = CByte(0)
        data(pos + 2) = CByte(255)
    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