「ポリ袋は海洋プラごみのわずか0.3％」だから

　レジ袋が有料化されて、話題になっています。
「ポリ袋は海洋プラごみのわずか0.3％」だから影響は小さいという意見があるそうです。
　へぇー。

　例えばの話ですが、60億人の0.3%は、1800万人です。0.3%を無視してもいいでしょうか？

　空気中の一酸化炭素の濃度が1500ppmを超えると、人は死に至るそうです。ppmはparts per millionなので、0.15%です。0.3%を無視してもいいでしょうか？

　数字が小さいから影響も小さいと考えるのは間違いです。

　数字が小さければ無視していい場合も多いですが、例えば0.3%のポリ袋でウミガメが絶滅してしまうというのであれば、それはやっぱり問題なんです。

　「ポリ袋は海洋プラごみのわずか0.3％」だから影響は小さいという主張は、ポリ袋は悪くないという結論に導こうとしているように感じます。


　ところで、そもそもの海洋プラごみの量の数字は信頼できるのでしょうか？きちんと調べていませんが、地球全体で調べるのは大変なので、たぶん精度は良くないと思います。数値の精度が信用できないのであれば、すべての議論が台無しになってしまいます。

　数値を出して議論するのは大切なことですが、数値があればいいというわけではありません。盲目に数字だけを見ていると、間違った結論に導かれるかもしれないので注意が必要です。


　一応、断っておきますが、私は別にレジ袋の有料化に賛成なわけではないです。私の場合、何年も前から買い物袋を常時携帯しているので、有料化は影響ないです。つまらないルールを作るなぁくらいに思っています。
　敢えて私の見解を述べるなら、規制されるまで何も考えずに大量にポリ袋を消費していることを、まず恥ずべきだと思います。不要なものを大量に消費するのは、環境にも経済にも良くないです。

P.S.
　「レジ袋」という名称は良くないですね。現代の日本でしか通じない言葉だと思います。「コンビニエンスストアなどで配布される、ポリエチレン製の買い物袋」では流石に長いですが。

コールセンターのお姉さんに感謝

　ちょっとお金が要り様になって、休日に銀行のATMに行きました。
　
　普通にキャッシュカードを入れたんですが、「このカードはお取り扱いできません。」って言われて、カードが出てきました。
　「あれっ」と思いつつ、もう1回試してみたら、今度は、カードが出てこなくなってしまいました。

　「どうしたもんか？」という感じだったのですが、画面の指示を見ると、壁の受話器を取れとのこと。受話器を取るとコールセンターにつながって、すぐに対応してくれました。

　カードが古くなって接触不良でも起こしたのでしょう。言われた通り、隣のATMを試したら、問題なく使えました。早めにカードを交換してくださいとのことです。

　あまり気にしたことはなかったのですが、銀行のATMって通信していて遠隔操作できるんですね。日本のどこにつながったのかは分かりませんが、世間の休日にお仕事してくれたお姉さんに感謝です。

Excelと3D Builderで遊ぼう 3

　3次元モデルが作れるとなると、当然、格子模型を作ってみたくなります (・・・たぶん)。というわけで、格子模型を作ってみました。
　3D Builderを使えば、いろいろな角度から眺められるので便利です。ちなみに球を使うと三角形の数が多くて面倒なので、それはパスしてます。

　ソースコードには前回、前々回のコードも入っているので、長ったらしくて申し訳ないです。まぁ、ご興味を持った方は、そのままコピペしてください。たいして難しいことはしていないので、見れば分かると思います。

　3D Builderは、基本的な立体を組み合わせたり、画像を読み込んで立体を作ったりするのが普通だと思いますが、Excelを使って直接座標を用意してやるのも悪くないと思います。(回転体とかをモデルするマクロを作ってみたりしても面白そうです。)

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

----------
2020/7/24 : せっかくなので、回転体も作成。

----------



Option Explicit

'==================================================
'STLファイル (Standard Triangulated Language)
'ASCII形式とBinary形式がある
'Unicode対応が面倒だったので、今回のマクロはBinaryのみ
'==================================================
'STLファイル(ASCII形式)の構造
'<solid開始> + <三角形データ> + <三角形データ> + ... + <solid終了>
'スペース区切り
'--------------------------------------------------
'solid name
' facet normal nx ny nz
'  outer loop
'   vertex v1x v1y v1z
'   vertex v2x v2y v2z
'   vertex v3x v3y v3z
'  endloop
' endfacet
' ...
'endsolid name
'--------------------------------------------------
'nameは適当な文字列
'nx, v1x, etc.は浮動小数点数 (1.000000e+01)
'座標はプラスの値のみ
'--------------------------------------------------
'例 (以下をテキストファイルで保存して、拡張子をstlにすると、3D Builderで読み込める)
'solid test
' facet normal 0.0000e+00 0.0000e+00 1.0000e+00
'  outer loop
'   vertex 2.0000e+00 1.0000e+00 0.0000e+00
'   vertex 5.0000e-01 1.8660e+00 0.0000e+00
'   vertex 5.0000e-01 1.3397e-01 0.0000e+00
'  endloop
' endfacet
'endsolid
'==================================================
'STLファイル(Binary形式)の構造
'<ヘッダ部> + <三角形データ> + <三角形データ>...
'Little Endianでいいらしい
'--------------------------------------------------
'<ヘッダ部>
'header_string  80bytes 80文字の任意文字列
'num_triangle   4bytes  三角形の個数 (整数)
'<三角形のデータ>
'nx     4bytes 法線ベクトル X (浮動小数点数)
'ny     4bytes 法線ベクトル Y (浮動小数点数)
'nz     4bytes 法線ベクトル Z (浮動小数点数)
'v1x    4bytes 頂点1 X座標 (浮動小数点数)
'v1y    4bytes 頂点1 Y座標 (浮動小数点数)
'v1z    4bytes 頂点1 Z座標 (浮動小数点数)
'v2x    4bytes 頂点2 X座標 (浮動小数点数)
'v2y    4bytes 頂点2 Y座標 (浮動小数点数)
'v2z    4bytes 頂点1 Z座標 (浮動小数点数)
'v3x    4bytes 頂点3 X座標 (浮動小数点数)
'v3y    4bytes 頂点3 Y座標 (浮動小数点数)
'v3z    4bytes 頂点3 Z座標 (浮動小数点数)
'data   2bytes 未使用データ
'--------------------------------------------------
'法線ベクトルは頂点から計算できるはず
'nx = (v2y - v1y) * (v3z - v1z) - (v2z - v1z) * (v3y - v1y)
'ny = (v2z - v1z) * (v3x - v1x) - (v2x - v1x) * (v3z - v1z)
'nz = (v2x - v1x) * (v3y - v1y) - (v2y - v1y) * (v3x - v1x)
'--------------------------------------------------

Public Const PI = 3.1415926535

'三角形データ
Private Type Facet
    N(2) As Single
    v(8) As Single
End Type

'変数の大きさの確認
Private Sub VariableSize()
    Dim i As Integer
    Dim l As Long
    Dim s As Single
    Dim d As Double
   
    MsgBox "Size of Integer : " & Len(i) & vbCrLf _
        & "Size of Long : " & Len(l) & vbCrLf _
        & "Size of Single : " & Len(s) & vbCrLf _
        & "Size of Double : " & Len(d)
End Sub

'ファイルのダンプ
Public Sub dump()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim read_size As Long
    Dim read_offset As Long
    Dim buf() As Byte
   
    Sheet1.Cells.Clear
   
    '------------------------------
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
    If Dir(filename) = "" Then Exit Sub
   
    '------------------------------
    'データの読み込み
    read_size = 1024
    read_offset = 0
   
    ReDim buf(read_size - 1) As Byte
   
    Open filename For Binary As 1
        'オフセット
        For i = 0 To read_offset - 1
            Get 1, , buf(0)
        Next i
       
        'Seek 1, read_offset + 1
       
        Get 1, , buf
    Close 1
   
    '------------------------------
    'データの表示
    Sheet1.Cells(1, 1) = "File Name"
    Sheet1.Cells(1, 2) = filename
    Sheet1.Cells(2, 1) = "File Size"
    Sheet1.Cells(2, 2) = FileLen(filename)
    Sheet1.Cells(3, 1) = "Read Size"
    Sheet1.Cells(3, 2) = read_size
    Sheet1.Cells(4, 1) = "Read Offset"
    Sheet1.Cells(4, 2) = read_offset
   
    For i = 0 To read_size / 16 - 1
        For j = 0 To 15
            '10進数表示
            Sheet1.Cells(i + 6, j + 1) = buf(i * 16 + j)
           
            '16進数表示
            'Sheet1.Cells(i + 6, j + 1) = Hex(buf(i * 16 + j))
           
            '文字列表示
            'Sheet1.Cells(i + 6, j + 1) = Chr(buf(i * 16 + j))
        Next j
    Next i
   
    '------------------------------
    Erase buf
End Sub

'正八面体
Public Sub sample_stl()
    Dim filename As String
    Dim data(7) As Facet
   
    Call SetFacet(data(0), 0, 0, Math.Sqr(2), 1, -1, 0, 1, 1, 0)
    Call SetFacet(data(1), 0, 0, Math.Sqr(2), 1, 1, 0, -1, 1, 0)
    Call SetFacet(data(2), 0, 0, Math.Sqr(2), -1, 1, 0, -1, -1, 0)
    Call SetFacet(data(3), 0, 0, Math.Sqr(2), -1, -1, 0, 1, -1, 0)
    Call SetFacet(data(4), 0, 0, -Math.Sqr(2), 1, 1, 0, 1, -1, 0)
    Call SetFacet(data(5), 0, 0, -Math.Sqr(2), -1, 1, 0, 1, 1, 0)
    Call SetFacet(data(6), 0, 0, -Math.Sqr(2), -1, -1, 0, -1, 1, 0)
    Call SetFacet(data(7), 0, 0, -Math.Sqr(2), 1, -1, 0, -1, -1, 0)
   
    filename = ThisWorkbook.Path + "\sample.stl"
   
    If Dir(filename) <> "" Then Kill filename
   
    Call write_stl_binary(filename, "sample", data)
End Sub

'正四面体
Public Sub sample_4()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Call SetRow(3, 1, 1, 1, -1, 1, -1, -1, -1, 1)
    Call SetRow(4, -1, -1, 1, 1, -1, -1, 1, 1, 1)
    Call SetRow(5, 1, 1, 1, 1, -1, -1, -1, 1, -1)
    Call SetRow(6, -1, 1, -1, 1, -1, -1, -1, -1, 1)
End Sub

'立方体
Public Sub sample_6()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Call SetRow(3, 1, 1, 1, -1, 1, 1, -1, -1, 1)
    Call SetRow(4, -1, -1, 1, 1, -1, 1, 1, 1, 1)
    Call SetRow(5, 1, 1, 1, 1, 1, -1, -1, 1, -1)
    Call SetRow(6, -1, 1, -1, -1, 1, 1, 1, 1, 1)
    Call SetRow(7, -1, 1, 1, -1, 1, -1, -1, -1, -1)
    Call SetRow(8, -1, -1, -1, -1, -1, 1, -1, 1, 1)
    Call SetRow(9, -1, -1, 1, -1, -1, -1, 1, -1, -1)
    Call SetRow(10, 1, -1, -1, 1, -1, 1, -1, -1, 1)
    Call SetRow(11, 1, -1, 1, 1, -1, -1, 1, 1, -1)
    Call SetRow(12, 1, 1, -1, 1, 1, 1, 1, -1, 1)
    Call SetRow(13, 1, 1, -1, 1, -1, -1, -1, -1, -1)
    Call SetRow(14, -1, -1, -1, -1, 1, -1, 1, 1, -1)
End Sub

'正二十面体
Public Sub sample_20()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim a As Single
    a = (1 + Math.Sqr(5)) / 2
   
    Call SetRow(3, 0, a, 1, 0, a, -1, -a, 1, 0)
    Call SetRow(4, 0, a, 1, a, 1, 0, 0, a, -1)
    Call SetRow(5, 0, -a, 1, -a, -1, 0, 0, -a, -1)
    Call SetRow(6, 0, -a, 1, 0, -a, -1, a, -1, 0)
    Call SetRow(7, 1, 0, a, 0, a, 1, -1, 0, a)
    Call SetRow(8, 1, 0, a, -1, 0, a, 0, -a, 1)
    Call SetRow(9, 1, 0, -a, -1, 0, -a, 0, a, -1)
    Call SetRow(10, 1, 0, -a, 0, -a, -1, -1, 0, -a)
    Call SetRow(11, a, 1, 0, a, -1, 0, 1, 0, -a)
    Call SetRow(12, a, 1, 0, 1, 0, a, a, -1, 0)
    Call SetRow(13, -a, 1, 0, -a, -1, 0, -1, 0, a)
    Call SetRow(14, -a, 1, 0, -1, 0, -a, -a, -1, 0)
    Call SetRow(15, 0, a, 1, 1, 0, a, a, 1, 0)
    Call SetRow(16, 0, a, 1, -a, 1, 0, -1, 0, a)
    Call SetRow(17, 0, -a, 1, -1, 0, a, -a, -1, 0)
    Call SetRow(18, 0, -a, 1, a, -1, 0, 1, 0, a)
    Call SetRow(19, 0, a, -1, a, 1, 0, 1, 0, -a)
    Call SetRow(20, 0, a, -1, -1, 0, -a, -a, 1, 0)
    Call SetRow(21, 0, -a, -1, -a, -1, 0, -1, 0, -a)
    Call SetRow(22, 0, -a, -1, 1, 0, -a, a, -1, 0)
End Sub

Public Sub sample_column()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim i As Long
    Dim j As Long
    Dim row As Long
   
    '------------------------------
    'パラメータ
    Dim a As Single
    Dim b As Single
    Dim c As Single
    Dim d As Single
   
    a = 12
    b = 2
    c = 4
    d = 1
   
    '------------------------------
    Dim x() As Single
    Dim y() As Single
    Dim z As Single
   
    ReDim x(a - 1) As Single
    ReDim y(a - 1) As Single
   
    For i = 0 To a - 1
        x(i) = Math.Cos(2 * PI * i / a)
        y(i) = Math.Sin(2 * PI * i / a)
    Next i
   
    z = 0
   
    row = 3
   
    '------------------------------
    '底面
    For i = 0 To a - 1
        Call SetRow(row, 0, 0, z, x((i + 1) Mod a), y((i + 1) Mod a), z, x(i), y(i), z)
        row = row + 1
    Next i
   
    '側面
    For i = 0 To c - 1
        For j = 0 To a - 1
            Call SetRow(row, x(j), y(j), z, x((j + 1) Mod a), y((j + 1) Mod a), z, x((j + b + 1) Mod a), y((j + b + 1) Mod a), z + d)
            Call SetRow(row + 1, x(j), y(j), z, x((j + b + 1) Mod a), y((j + b + 1) Mod a), z + d, x((j + b) Mod a), y((j + b) Mod a), z + d)
            row = row + 2
        Next j
       
        z = z + d
    Next i
   
    '上面
    For i = 0 To a - 1
        Call SetRow(row, 0, 0, z, x(i), y(i), z, x((i + 1) Mod a), y((i + 1) Mod a), z)
        row = row + 1
    Next i
End Sub

Public Sub sample_object()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim a As Single
    a = 10

    Call AddRectangular(0, 0, 0, 20, 4, 4)
    Call AddRectangular(0, 0, 0, 4, 20, 4)
    Call AddRectangular(0, 0, 0, 4, 4, 20)
End Sub

'回転体のサンプル
'zの両端でr = 0とはできないので注意
Public Sub sample_rotating_body()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim z(5) As Single
    Dim r(5) As Single
   
    z(0) = 0
    r(0) = 4
    z(1) = 0.5
    r(1) = 4
    z(2) = 0.5
    r(2) = 0.5
    z(3) = 8
    r(3) = 0.5
    z(4) = 16
    r(4) = 4
    z(5) = 20
    r(5) = 3.5
   
    Call AddRotatingBody(z, r)
End Sub

Public Sub sample_BCC_lattice()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim a As Single
    a = 10
   
    Call AddCube(0, 0, 0)
    Call AddCube(a, a, a)
    Call AddCube(-a, a, a)
    Call AddCube(-a, -a, a)
    Call AddCube(a, -a, a)
    Call AddCube(a, a, -a)
    Call AddCube(-a, a, -a)
    Call AddCube(-a, -a, -a)
    Call AddCube(a, -a, -a)
End Sub

Public Sub sample_FCC_lattice()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim a As Single
    a = 10
   
    Call AddOctahedron(a, a, a)
    Call AddOctahedron(-a, a, a)
    Call AddOctahedron(-a, -a, a)
    Call AddOctahedron(a, -a, a)
   
    Call AddOctahedron(a, a, -a)
    Call AddOctahedron(-a, a, -a)
    Call AddOctahedron(-a, -a, -a)
    Call AddOctahedron(a, -a, -a)

    Call AddOctahedron(0, 0, -a)
    Call AddOctahedron(a, 0, 0)
    Call AddOctahedron(0, a, 0)
    Call AddOctahedron(-a, 0, 0)
    Call AddOctahedron(0, -a, 0)
    Call AddOctahedron(0, 0, a)
End Sub

Public Sub sample_Diamond_lattice()
    Call SetRowTitle
   
    Sheet1.Cells(1, 1) = "sample"
   
    Dim a As Single
    a = 10
   
    Call AddOctahedron(a, a, a)
    Call AddOctahedron(-a, a, a)
    Call AddOctahedron(-a, -a, a)
    Call AddOctahedron(a, -a, a)
   
    Call AddOctahedron(a, a, -a)
    Call AddOctahedron(-a, a, -a)
    Call AddOctahedron(-a, -a, -a)
    Call AddOctahedron(a, -a, -a)

    Call AddOctahedron(0, 0, -a)
    Call AddOctahedron(a, 0, 0)
    Call AddOctahedron(0, a, 0)
    Call AddOctahedron(-a, 0, 0)
    Call AddOctahedron(0, -a, 0)
    Call AddOctahedron(0, 0, a)

    Call AddOctahedron(a + a / 2, a + a / 2, a + a / 2)
    Call AddOctahedron(-a + a / 2, a + a / 2, a + a / 2)
    Call AddOctahedron(-a + a / 2, -a + a / 2, a + a / 2)
    Call AddOctahedron(a + a / 2, -a + a / 2, a + a / 2)
   
    Call AddOctahedron(a + a / 2, a + a / 2, -a + a / 2)
    Call AddOctahedron(-a + a / 2, a + a / 2, -a + a / 2)
    Call AddOctahedron(-a + a / 2, -a + a / 2, -a + a / 2)
    Call AddOctahedron(a + a / 2, -a + a / 2, -a + a / 2)

    Call AddOctahedron(0 + a / 2, 0 + a / 2, -a + a / 2)
    Call AddOctahedron(a + a / 2, 0 + a / 2, 0 + a / 2)
    Call AddOctahedron(0 + a / 2, a + a / 2, 0 + a / 2)
    Call AddOctahedron(-a + a / 2, 0 + a / 2, 0 + a / 2)
    Call AddOctahedron(0 + a / 2, -a + a / 2, 0 + a / 2)
    Call AddOctahedron(0 + a / 2, 0 + a / 2, a + a / 2)
End Sub

Private Sub AddCube(cx As Single, cy As Single, cz As Single)
    Dim row As Long
   
    row = 2
   
    Do While Sheet1.Cells(row, 1) <> ""
        row = row + 1
    Loop
   
    Call SetRow(row + 0, cx + 1, cy + 1, cz + 1, cx - 1, cy + 1, cz + 1, cx - 1, cy - 1, cz + 1)
    Call SetRow(row + 1, cx - 1, cy - 1, cz + 1, cx + 1, cy - 1, cz + 1, cx + 1, cy + 1, cz + 1)
    Call SetRow(row + 2, cx + 1, cy + 1, cz + 1, cx + 1, cy + 1, cz - 1, cx - 1, cy + 1, cz - 1)
    Call SetRow(row + 3, cx - 1, cy + 1, cz - 1, cx - 1, cy + 1, cz + 1, cx + 1, cy + 1, cz + 1)
    Call SetRow(row + 4, cx - 1, cy + 1, cz + 1, cx - 1, cy + 1, cz - 1, cx - 1, cy - 1, cz - 1)
    Call SetRow(row + 5, cx - 1, cy - 1, cz - 1, cx - 1, cy - 1, cz + 1, cx - 1, cy + 1, cz + 1)
    Call SetRow(row + 6, cx - 1, cy - 1, cz + 1, cx - 1, cy - 1, cz - 1, cx + 1, cy - 1, cz - 1)
    Call SetRow(row + 7, cx + 1, cy - 1, cz - 1, cx + 1, cy - 1, cz + 1, cx - 1, cy - 1, cz + 1)
    Call SetRow(row + 8, cx + 1, cy - 1, cz + 1, cx + 1, cy - 1, cz - 1, cx + 1, cy + 1, cz - 1)
    Call SetRow(row + 9, cx + 1, cy + 1, cz - 1, cx + 1, cy + 1, cz + 1, cx + 1, cy - 1, cz + 1)
    Call SetRow(row + 10, cx + 1, cy + 1, cz - 1, cx + 1, cy - 1, cz - 1, cx - 1, cy - 1, cz - 1)
    Call SetRow(row + 11, cx - 1, cy - 1, cz - 1, cx - 1, cy + 1, cz - 1, cx + 1, cy + 1, cz - 1)
End Sub

Private Sub AddRectangular(cx As Single, cy As Single, cz As Single, w As Single, h As Single, d As Single)
    Dim row As Long
   
    row = 2
   
    Do While Sheet1.Cells(row, 1) <> ""
        row = row + 1
    Loop
   
    Call SetRow(row + 0, cx + w / 2, cy + h / 2, cz + d / 2, cx - w / 2, cy + h / 2, cz + d / 2, cx - w / 2, cy - h / 2, cz + d / 2)
    Call SetRow(row + 1, cx - w / 2, cy - h / 2, cz + d / 2, cx + w / 2, cy - h / 2, cz + d / 2, cx + w / 2, cy + h / 2, cz + d / 2)
    Call SetRow(row + 2, cx + w / 2, cy + h / 2, cz + d / 2, cx + w / 2, cy + h / 2, cz - d / 2, cx - w / 2, cy + h / 2, cz - d / 2)
    Call SetRow(row + 3, cx - w / 2, cy + h / 2, cz - d / 2, cx - w / 2, cy + h / 2, cz + d / 2, cx + w / 2, cy + h / 2, cz + d / 2)
    Call SetRow(row + 4, cx - w / 2, cy + h / 2, cz + d / 2, cx - w / 2, cy + h / 2, cz - d / 2, cx - w / 2, cy - h / 2, cz - d / 2)
    Call SetRow(row + 5, cx - w / 2, cy - h / 2, cz - d / 2, cx - w / 2, cy - h / 2, cz + d / 2, cx - w / 2, cy + h / 2, cz + d / 2)
    Call SetRow(row + 6, cx - w / 2, cy - h / 2, cz + d / 2, cx - w / 2, cy - h / 2, cz - d / 2, cx + w / 2, cy - h / 2, cz - d / 2)
    Call SetRow(row + 7, cx + w / 2, cy - h / 2, cz - d / 2, cx + w / 2, cy - h / 2, cz + d / 2, cx - w / 2, cy - h / 2, cz + d / 2)
    Call SetRow(row + 8, cx + w / 2, cy - h / 2, cz + d / 2, cx + w / 2, cy - h / 2, cz - d / 2, cx + w / 2, cy + h / 2, cz - d / 2)
    Call SetRow(row + 9, cx + w / 2, cy + h / 2, cz - d / 2, cx + w / 2, cy + h / 2, cz + d / 2, cx + w / 2, cy - h / 2, cz + d / 2)
    Call SetRow(row + 10, cx + w / 2, cy + h / 2, cz - d / 2, cx + w / 2, cy - h / 2, cz - d / 2, cx - w / 2, cy - h / 2, cz - d / 2)
    Call SetRow(row + 11, cx - w / 2, cy - h / 2, cz - d / 2, cx - w / 2, cy + h / 2, cz - d / 2, cx + w / 2, cy + h / 2, cz - d / 2)
End Sub

Private Sub AddOctahedron(cx As Single, cy As Single, cz As Single)
    Dim row As Long
   
    row = 2
   
    Do While Sheet1.Cells(row, 1) <> ""
        row = row + 1
    Loop
   
    Call SetRow(row + 0, cx, cy, cz + Math.Sqr(2), cx + 1, cy - 1, cz, cx + 1, cy + 1, cz)
    Call SetRow(row + 1, cx, cy, cz + Math.Sqr(2), cx + 1, cy + 1, cz, cx - 1, cy + 1, cz)
    Call SetRow(row + 2, cx, cy, cz + Math.Sqr(2), cx - 1, cy + 1, cz, cx - 1, cy - 1, cz)
    Call SetRow(row + 3, cx, cy, cz + Math.Sqr(2), cx - 1, cy - 1, cz, cx + 1, cy - 1, cz)
   
    Call SetRow(row + 4, cx, cy, cz - Math.Sqr(2), cx + 1, cy + 1, cz, cx + 1, cy - 1, cz)
    Call SetRow(row + 5, cx, cy, cz - Math.Sqr(2), cx - 1, cy + 1, cz, cx + 1, cy + 1, cz)
    Call SetRow(row + 6, cx, cy, cz - Math.Sqr(2), cx - 1, cy - 1, cz, cx - 1, cy + 1, cz)
    Call SetRow(row + 7, cx, cy, cz - Math.Sqr(2), cx + 1, cy - 1, cz, cx - 1, cy - 1, cz)
End Sub

Private Sub AddRotatingBody(z() As Single, r() As Single)
    Dim i As Long
    Dim j As Long
    Dim N As Long
    Dim row As Long
   
    Dim cos1 As Double
    Dim sin1 As Double
    Dim cos2 As Double
    Dim sin2 As Double
   
    '------------------------------
    If UBound(z) <> UBound(r) Then
        MsgBox "Error (AddRotatingBody)", vbExclamation
        Exit Sub
    End If
   
    If UBound(z) < 2 Then
        MsgBox "Error (AddRotatingBody)", vbExclamation
        Exit Sub
    End If
   
    For i = LBound(r) To UBound(r)
        If r(j) < 0.000000001 Then
            MsgBox "Error (AddRotatingBody)", vbExclamation
            Exit Sub
        End If
    Next i
   
    '------------------------------
    row = 2
   
    Do While Sheet1.Cells(row, 1) <> ""
        row = row + 1
    Loop
   
    '------------------------------
    N = 16
   
    '底面
    j = LBound(z)
   
    For i = 0 To N - 1
        cos1 = Math.Cos(2 * PI * i / N)
        sin1 = Math.Sin(2 * PI * i / N)
        cos2 = Math.Cos(2 * PI * (i + 1) / N)
        sin2 = Math.Sin(2 * PI * (i + 1) / N)
       
        Call SetRow(row, 0, 0, z(j), r(j) * cos2, r(j) * sin2, z(j), r(j) * cos1, r(j) * sin1, z(j))
           
        row = row + 1
    Next i
   
    '側面
    For j = LBound(z) To UBound(z) - 1
        For i = 0 To N - 1
            cos1 = Math.Cos(2 * PI * i / N)
            sin1 = Math.Sin(2 * PI * i / N)
            cos2 = Math.Cos(2 * PI * (i + 1) / N)
            sin2 = Math.Sin(2 * PI * (i + 1) / N)
           
            Call SetRow(row, r(j) * cos1, r(j) * sin1, z(j), r(j) * cos2, r(j) * sin2, z(j), r(j + 1) * cos1, r(j + 1) * sin1, z(j + 1))
               
            row = row + 1
           
            Call SetRow(row, r(j + 1) * cos1, r(j + 1) * sin1, z(j + 1), r(j) * cos2, r(j) * sin2, z(j), r(j + 1) * cos2, r(j + 1) * sin2, z(j + 1))
               
            row = row + 1
        Next i
    Next j
   
    '上面
    j = UBound(z)
   
    For i = 0 To N - 1
        cos1 = Math.Cos(2 * PI * i / N)
        sin1 = Math.Sin(2 * PI * i / N)
        cos2 = Math.Cos(2 * PI * (i + 1) / N)
        sin2 = Math.Sin(2 * PI * (i + 1) / N)
       
        Call SetRow(row, 0, 0, z(j), r(j) * cos1, r(j) * sin1, z(j), r(j) * cos2, r(j) * sin2, z(j))
           
        row = row + 1
    Next i
End Sub

Public Sub write_stl()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim name As String
    Dim count As Long
    Dim data() As Facet
    Dim temp(8) As Single
   
    '------------------------------
    name = Sheet1.Cells(1, 1)
   
    count = Sheet1.Cells(2, 1).End(xlDown).row - 2
   
    ReDim data(count - 1) As Facet
   
    For i = 0 To count - 1
        For j = 0 To 8
            temp(j) = Sheet1.Cells(i + 3, j + 1)
        Next j
       
        SetFacet data(i), temp(0), temp(1), temp(2), temp(3), temp(4), temp(5), temp(6), temp(7), temp(8)
    Next i
   
    '------------------------------
    filename = ThisWorkbook.Path + "\sample.stl"
   
    If Dir(filename) <> "" Then Kill filename
   
    Call write_stl_binary(filename, name, data)
End Sub

Private Sub SetFacet(ByRef f As Facet, _
    x1 As Single, y1 As Single, z1 As Single, _
    x2 As Single, y2 As Single, z2 As Single, _
    x3 As Single, y3 As Single, z3 As Single)

    '------------------------------
    f.v(0) = x1
    f.v(1) = y1
    f.v(2) = z1
    f.v(3) = x2
    f.v(4) = y2
    f.v(5) = z2
    f.v(6) = x3
    f.v(7) = y3
    f.v(8) = z3
   
    '------------------------------
    '法線ベクトルの計算
    Dim temp(6) As Single
   
    temp(0) = f.v(3) - f.v(0)
    temp(1) = f.v(4) - f.v(1)
    temp(2) = f.v(5) - f.v(2)
    temp(3) = f.v(6) - f.v(0)
    temp(4) = f.v(7) - f.v(1)
    temp(5) = f.v(8) - f.v(2)
   
    f.N(0) = temp(1) * temp(5) - temp(2) * temp(4)
    f.N(1) = temp(2) * temp(3) - temp(0) * temp(5)
    f.N(2) = temp(0) * temp(4) - temp(1) * temp(3)
   
    temp(6) = Math.Sqr(f.N(0) * f.N(0) + f.N(1) * f.N(1) + f.N(2) * f.N(2))
   
    If temp(6) < 0.000000001 Then
        MsgBox "Error (SetFacet)"
        Exit Sub
    End If
   
    f.N(0) = f.N(0) / temp(6)
    f.N(1) = f.N(1) / temp(6)
    f.N(2) = f.N(2) / temp(6)
End Sub

Private Sub SetRowTitle()
    Sheet1.Cells.Clear
   
    Sheet1.Cells(2, 1) = "v1x"
    Sheet1.Cells(2, 2) = "v1y"
    Sheet1.Cells(2, 3) = "v1z"
    Sheet1.Cells(2, 4) = "v2x"
    Sheet1.Cells(2, 5) = "v2y"
    Sheet1.Cells(2, 6) = "v2z"
    Sheet1.Cells(2, 7) = "v3x"
    Sheet1.Cells(2, 8) = "v3y"
    Sheet1.Cells(2, 9) = "v3z"
End Sub

Private Sub SetRow(row As Long, _
    x1 As Single, y1 As Single, z1 As Single, _
    x2 As Single, y2 As Single, z2 As Single, _
    x3 As Single, y3 As Single, z3 As Single)

    Sheet1.Cells(row, 1) = x1
    Sheet1.Cells(row, 2) = y1
    Sheet1.Cells(row, 3) = z1
    Sheet1.Cells(row, 4) = x2
    Sheet1.Cells(row, 5) = y2
    Sheet1.Cells(row, 6) = z2
    Sheet1.Cells(row, 7) = x3
    Sheet1.Cells(row, 8) = y3
    Sheet1.Cells(row, 9) = z3
End Sub

Public Sub read_stl()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim name As String
    Dim data() As Facet
   
    '------------------------------
    ChDir ThisWorkbook.Path
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
    If Dir(filename) = "" Then Exit Sub
   
    Call read_stl_binary(filename, name, data)
   
    '------------------------------
    Call SetRowTitle
   
    '法線ベクトルの表示 On/Off
    If False Then
        Sheet1.Cells(2, 10) = "nx"
        Sheet1.Cells(2, 11) = "ny"
        Sheet1.Cells(2, 12) = "nz"
    End If
   
    Sheet1.Cells(1, 1) = name
   
    For i = LBound(data) To UBound(data)
        Call SetRow(i + 3, data(i).v(0), data(i).v(1), data(i).v(2), data(i).v(3), data(i).v(4), data(i).v(5), data(i).v(6), data(i).v(7), data(i).v(8))
       
        '法線ベクトルの表示 On/Off
        If False Then
            Sheet1.Cells(i + 3, 10) = data(i).N(0)
            Sheet1.Cells(i + 3, 11) = data(i).N(1)
            Sheet1.Cells(i + 3, 12) = data(i).N(2)
        End If
    Next i
End Sub

'Binary形式のSTLファイルの書き出し
Public Sub write_stl_binary(filename As String, ByRef name As String, ByRef data() As Facet)
    Dim i As Long
    Dim buf() As Byte

    On Error GoTo Label1
   
    Open filename For Binary As 1
        '任意の80文字 (Asciiコードのみ対応)
        ReDim buf(79) As Byte
       
        For i = 0 To 79
            If i < Len(name) Then
                buf(i) = Asc(Mid(name, i + 1, 1))
            Else
                buf(i) = 0
            End If
        Next i
       
        Put 1, , buf
       
        '三角形の個数
        i = UBound(data) - LBound(data) + 1
        Put 1, , i
       
        ReDim buf(1) As Byte
        buf(0) = CByte(0)
        buf(1) = CByte(0)
       
        '三角形
        For i = LBound(data) To UBound(data)
            Put 1, , data(i).N
            Put 1, , data(i).v
            Put 1, , buf
        Next i
    Close 1
   
    Exit Sub
Label1:
    Close 1
    MsgBox "Error (write_stl_binary)", vbExclamation
End Sub

'Binary形式のSTLファイルの読み込み
Public Sub read_stl_binary(filename As String, ByRef name As String, ByRef data() As Facet)
    Dim i As Long
    Dim buf() As Byte
   
    On Error GoTo Label1
   
    Open filename For Binary As 1
        '任意の80文字 (Asciiコードのみ対応)
        ReDim buf(79) As Byte
        Get 1, , buf
       
        name = ""
       
        For i = 0 To 79
            If buf(i) = 0 Then Exit For
           
            name = name & Chr(buf(i))
        Next i
       
        '三角形の個数
        Get 1, , i
        ReDim data(i - 1) As Facet
       
        ReDim buf(1) As Byte
       
        '三角形
        For i = LBound(data) To UBound(data)
            Get 1, , data(i).N
            Get 1, , data(i).v
            Get 1, , buf
        Next i
    Close 1
   
    Exit Sub
Label1:
    Close 1
    MsgBox "Error (read_stl_binary)", vbExclamation
End Sub

Excelと3D Builderで遊ぼう 2

　前回は、簡単なSTLファイルの保存と読み込みだけだったので、今回はもう少しいろいろ作ってみました。
　write_stl関数は、sample.stlファイルを作成します。他の関数は3次元モデルの座標の例です。正しいモデルになるように座標を計算するのは少し大変です。座標が間違っていると、3D Builderに怒られます。

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



Option Explicit

'==================================================
'STLファイル (Standard Triangulated Language)
'ASCII形式とBinary形式がある
'Unicode対応が面倒だったので、今回のマクロはBinaryのみ
'==================================================
'STLファイル(ASCII形式)の構造
'<solid開始> + <三角形データ> + <三角形データ> + ... + <solid終了>
'スペース区切り
'--------------------------------------------------
'solid name
' facet normal nx ny nz
'  outer loop
'   vertex v1x v1y v1z
'   vertex v2x v2y v2z
'   vertex v3x v3y v3z
'  endloop
' endfacet
' ...
'endsolid name
'--------------------------------------------------
'nameは適当な文字列
'nx, v1x, etc.は浮動小数点数 (1.000000e+01)
'座標はプラスの値のみ
'--------------------------------------------------
'例 (以下をテキストファイルで保存して、拡張子をstlにすると、3D Builderで読み込める)
'solid test
' facet normal 0.0000e+00 0.0000e+00 1.0000e+00
'  outer loop
'   vertex 2.0000e+00 1.0000e+00 0.0000e+00
'   vertex 5.0000e-01 1.8660e+00 0.0000e+00
'   vertex 5.0000e-01 1.3397e-01 0.0000e+00
'  endloop
' endfacet
'endsolid
'==================================================
'STLファイル(Binary形式)の構造
'<ヘッダ部> + <三角形データ> + <三角形データ>...
'Little Endianでいいらしい
'--------------------------------------------------
'<ヘッダ部>
'header_string  80bytes 80文字の任意文字列
'num_triangle   4bytes  三角形の個数 (整数)
'<三角形のデータ>
'nx     4bytes 法線ベクトル X (浮動小数点数)
'ny     4bytes 法線ベクトル Y (浮動小数点数)
'nz     4bytes 法線ベクトル Z (浮動小数点数)
'v1x    4bytes 頂点1 X座標 (浮動小数点数)
'v1y    4bytes 頂点1 Y座標 (浮動小数点数)
'v1z    4bytes 頂点1 Z座標 (浮動小数点数)
'v2x    4bytes 頂点2 X座標 (浮動小数点数)
'v2y    4bytes 頂点2 Y座標 (浮動小数点数)
'v2z    4bytes 頂点1 Z座標 (浮動小数点数)
'v3x    4bytes 頂点3 X座標 (浮動小数点数)
'v3y    4bytes 頂点3 Y座標 (浮動小数点数)
'v3z    4bytes 頂点3 Z座標 (浮動小数点数)
'data   2bytes 未使用データ
'--------------------------------------------------
'法線ベクトルは頂点から計算できるはず
'nx = (v2y - v1y) * (v3z - v1z) - (v2z - v1z) * (v3y - v1y)
'ny = (v2z - v1z) * (v3x - v1x) - (v2x - v1x) * (v3z - v1z)
'nz = (v2x - v1x) * (v3y - v1y) - (v2y - v1y) * (v3x - v1x)
'--------------------------------------------------

Public Const PI = 3.1415926535

'三角形データ
Private Type Facet
    n(2) As Single
    v(8) As Single
End Type

'変数の大きさの確認
Private Sub VariableSize()
    Dim i As Integer
    Dim l As Long
    Dim s As Single
    Dim d As Double
 
    MsgBox "Size of Integer : " & Len(i) & vbCrLf _
        & "Size of Long : " & Len(l) & vbCrLf _
        & "Size of Single : " & Len(s) & vbCrLf _
        & "Size of Double : " & Len(d)
End Sub

'ファイルのダンプ
Public Sub dump()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim read_size As Long
    Dim read_offset As Long
    Dim buf() As Byte
 
    Sheet1.Cells.Clear
 
    '------------------------------
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
    If Dir(filename) = "" Then Exit Sub
 
    '------------------------------
    'データの読み込み
    read_size = 1024
    read_offset = 0
 
    ReDim buf(read_size - 1) As Byte
 
    Open filename For Binary As 1
        'オフセット
        For i = 0 To read_offset - 1
            Get 1, , buf(0)
        Next i
     
        'Seek 1, read_offset + 1
     
        Get 1, , buf
    Close 1
 
    '------------------------------
    'データの表示
    Sheet1.Cells(1, 1) = "File Name"
    Sheet1.Cells(1, 2) = filename
    Sheet1.Cells(2, 1) = "File Size"
    Sheet1.Cells(2, 2) = FileLen(filename)
    Sheet1.Cells(3, 1) = "Read Size"
    Sheet1.Cells(3, 2) = read_size
    Sheet1.Cells(4, 1) = "Read Offset"
    Sheet1.Cells(4, 2) = read_offset
 
    For i = 0 To read_size / 16 - 1
        For j = 0 To 15
            '10進数表示
            Sheet1.Cells(i + 6, j + 1) = buf(i * 16 + j)
         
            '16進数表示
            'Sheet1.Cells(i + 6, j + 1) = Hex(buf(i * 16 + j))
         
            '文字列表示
            'Sheet1.Cells(i + 6, j + 1) = Chr(buf(i * 16 + j))
        Next j
    Next i
 
    '------------------------------
    Erase buf
End Sub

'正八面体
Public Sub sample_stl()
    Dim filename As String
    Dim data(7) As Facet
 
    Call SetFacet(data(0), 0, 0, Math.Sqr(2), 1, -1, 0, 1, 1, 0)
    Call SetFacet(data(1), 0, 0, Math.Sqr(2), 1, 1, 0, -1, 1, 0)
    Call SetFacet(data(2), 0, 0, Math.Sqr(2), -1, 1, 0, -1, -1, 0)
    Call SetFacet(data(3), 0, 0, Math.Sqr(2), -1, -1, 0, 1, -1, 0)
    Call SetFacet(data(4), 0, 0, -Math.Sqr(2), 1, 1, 0, 1, -1, 0)
    Call SetFacet(data(5), 0, 0, -Math.Sqr(2), -1, 1, 0, 1, 1, 0)
    Call SetFacet(data(6), 0, 0, -Math.Sqr(2), -1, -1, 0, -1, 1, 0)
    Call SetFacet(data(7), 0, 0, -Math.Sqr(2), 1, -1, 0, -1, -1, 0)
 
    filename = ThisWorkbook.Path + "\sample.stl"
 
    If Dir(filename) <> "" Then Kill filename
 
    Call write_stl_binary(filename, "sample", data)
End Sub

'正四面体
Public Sub sample_4()
    Call SetRowTitle
 
    Sheet1.Cells(1, 1) = "sample"
 
    Call SetRow(3, 1, 1, 1, -1, 1, -1, -1, -1, 1)
    Call SetRow(4, -1, -1, 1, 1, -1, -1, 1, 1, 1)
    Call SetRow(5, 1, 1, 1, 1, -1, -1, -1, 1, -1)
    Call SetRow(6, -1, 1, -1, 1, -1, -1, -1, -1, 1)
End Sub

'立方体
Public Sub sample_6()
    Call SetRowTitle
 
    Sheet1.Cells(1, 1) = "sample"
 
    Call SetRow(3, 1, 1, 1, -1, 1, 1, -1, -1, 1)
    Call SetRow(4, -1, -1, 1, 1, -1, 1, 1, 1, 1)
    Call SetRow(5, 1, 1, 1, 1, 1, -1, -1, 1, -1)
    Call SetRow(6, -1, 1, -1, -1, 1, 1, 1, 1, 1)
    Call SetRow(7, -1, 1, 1, -1, 1, -1, -1, -1, -1)
    Call SetRow(8, -1, -1, -1, -1, -1, 1, -1, 1, 1)
    Call SetRow(9, -1, -1, 1, -1, -1, -1, 1, -1, -1)
    Call SetRow(10, 1, -1, -1, 1, -1, 1, -1, -1, 1)
    Call SetRow(11, 1, -1, 1, 1, -1, -1, 1, 1, -1)
    Call SetRow(12, 1, 1, -1, 1, 1, 1, 1, -1, 1)
    Call SetRow(13, 1, 1, -1, 1, -1, -1, -1, -1, -1)
    Call SetRow(14, -1, -1, -1, -1, 1, -1, 1, 1, -1)
End Sub

'正二十面体
Public Sub sample_20()
    Call SetRowTitle
 
    Sheet1.Cells(1, 1) = "sample"
 
    Dim a As Single
    a = (1 + Math.Sqr(5)) / 2
 
    Call SetRow(3, 0, a, 1, 0, a, -1, -a, 1, 0)
    Call SetRow(4, 0, a, 1, a, 1, 0, 0, a, -1)
    Call SetRow(5, 0, -a, 1, -a, -1, 0, 0, -a, -1)
    Call SetRow(6, 0, -a, 1, 0, -a, -1, a, -1, 0)
    Call SetRow(7, 1, 0, a, 0, a, 1, -1, 0, a)
    Call SetRow(8, 1, 0, a, -1, 0, a, 0, -a, 1)
    Call SetRow(9, 1, 0, -a, -1, 0, -a, 0, a, -1)
    Call SetRow(10, 1, 0, -a, 0, -a, -1, -1, 0, -a)
    Call SetRow(11, a, 1, 0, a, -1, 0, 1, 0, -a)
    Call SetRow(12, a, 1, 0, 1, 0, a, a, -1, 0)
    Call SetRow(13, -a, 1, 0, -a, -1, 0, -1, 0, a)
    Call SetRow(14, -a, 1, 0, -1, 0, -a, -a, -1, 0)
    Call SetRow(15, 0, a, 1, 1, 0, a, a, 1, 0)
    Call SetRow(16, 0, a, 1, -a, 1, 0, -1, 0, a)
    Call SetRow(17, 0, -a, 1, -1, 0, a, -a, -1, 0)
    Call SetRow(18, 0, -a, 1, a, -1, 0, 1, 0, a)
    Call SetRow(19, 0, a, -1, a, 1, 0, 1, 0, -a)
    Call SetRow(20, 0, a, -1, -1, 0, -a, -a, 1, 0)
    Call SetRow(21, 0, -a, -1, -a, -1, 0, -1, 0, -a)
    Call SetRow(22, 0, -a, -1, 1, 0, -a, a, -1, 0)
End Sub

Public Sub sample_column()
    Call SetRowTitle
 
    Sheet1.Cells(1, 1) = "sample"
 
    Dim i As Long
    Dim j As Long
    Dim row As Long
 
    '------------------------------
    'パラメータ
    Dim a As Single
    Dim b As Single
    Dim c As Single
    Dim d As Single
 
    a = 12
    b = 2
    c = 4
    d = 1
 
    '------------------------------
    Dim x() As Single
    Dim y() As Single
    Dim z As Single
 
    ReDim x(a - 1) As Single
    ReDim y(a - 1) As Single
 
    For i = 0 To a - 1
        x(i) = Math.Cos(2 * PI * i / a)
        y(i) = Math.Sin(2 * PI * i / a)
    Next i
 
    z = 0
 
    row = 3
 
    '------------------------------
    '底面
    For i = 0 To a - 1
        Call SetRow(row, 0, 0, z, x((i + 1) Mod a), y((i + 1) Mod a), z, x(i), y(i), z)
        row = row + 1
    Next i
 
    '側面
    For i = 0 To c - 1
        For j = 0 To a - 1
            Call SetRow(row, x(j), y(j), z, x((j + 1) Mod a), y((j + 1) Mod a), z, x((j + b + 1) Mod a), y((j + b + 1) Mod a), z + d)
            Call SetRow(row + 1, x(j), y(j), z, x((j + b + 1) Mod a), y((j + b + 1) Mod a), z + d, x((j + b) Mod a), y((j + b) Mod a), z + d)
            row = row + 2
        Next j
     
        z = z + d
    Next i
 
    '上面
    For i = 0 To a - 1
        Call SetRow(row, 0, 0, z, x(i), y(i), z, x((i + 1) Mod a), y((i + 1) Mod a), z)
        row = row + 1
    Next i
End Sub

Public Sub write_stl()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim name As String
    Dim count As Long
    Dim data() As Facet
    Dim temp(8) As Single
 
    '------------------------------
    name = Sheet1.Cells(1, 1)
 
    count = Sheet1.Cells(2, 1).End(xlDown).row - 2
 
    ReDim data(count - 1) As Facet
 
    For i = 0 To count - 1
        For j = 0 To 8
            temp(j) = Sheet1.Cells(i + 3, j + 1)
        Next j
     
        SetFacet data(i), temp(0), temp(1), temp(2), temp(3), temp(4), temp(5), temp(6), temp(7), temp(8)
    Next i
 
    '------------------------------
    filename = ThisWorkbook.Path + "\sample.stl"
 
    If Dir(filename) <> "" Then Kill filename
 
    Call write_stl_binary(filename, name, data)
End Sub

Private Sub SetFacet(ByRef f As Facet, _
    x1 As Single, y1 As Single, z1 As Single, _
    x2 As Single, y2 As Single, z2 As Single, _
    x3 As Single, y3 As Single, z3 As Single)

    '------------------------------
    f.v(0) = x1
    f.v(1) = y1
    f.v(2) = z1
    f.v(3) = x2
    f.v(4) = y2
    f.v(5) = z2
    f.v(6) = x3
    f.v(7) = y3
    f.v(8) = z3
 
    '------------------------------
    '法線ベクトルの計算
    Dim temp(6) As Single
 
    temp(0) = f.v(3) - f.v(0)
    temp(1) = f.v(4) - f.v(1)
    temp(2) = f.v(5) - f.v(2)
    temp(3) = f.v(6) - f.v(0)
    temp(4) = f.v(7) - f.v(1)
    temp(5) = f.v(8) - f.v(2)
 
    f.n(0) = temp(1) * temp(5) - temp(2) * temp(4)
    f.n(1) = temp(2) * temp(3) - temp(0) * temp(5)
    f.n(2) = temp(0) * temp(4) - temp(1) * temp(3)
 
    temp(6) = Math.Sqr(f.n(0) * f.n(0) + f.n(1) * f.n(1) + f.n(2) * f.n(2))
 
    If temp(6) < 0.000000001 Then
        MsgBox "Error (SetFacet)"
        Exit Sub
    End If
 
    f.n(0) = f.n(0) / temp(6)
    f.n(1) = f.n(1) / temp(6)
    f.n(2) = f.n(2) / temp(6)
End Sub

Private Sub SetRowTitle()
    Sheet1.Cells.Clear
 
    Sheet1.Cells(2, 1) = "v1x"
    Sheet1.Cells(2, 2) = "v1y"
    Sheet1.Cells(2, 3) = "v1z"
    Sheet1.Cells(2, 4) = "v2x"
    Sheet1.Cells(2, 5) = "v2y"
    Sheet1.Cells(2, 6) = "v2z"
    Sheet1.Cells(2, 7) = "v3x"
    Sheet1.Cells(2, 8) = "v3y"
    Sheet1.Cells(2, 9) = "v3z"
End Sub

Private Sub SetRow(row As Long, _
    x1 As Single, y1 As Single, z1 As Single, _
    x2 As Single, y2 As Single, z2 As Single, _
    x3 As Single, y3 As Single, z3 As Single)

    Sheet1.Cells(row, 1) = x1
    Sheet1.Cells(row, 2) = y1
    Sheet1.Cells(row, 3) = z1
    Sheet1.Cells(row, 4) = x2
    Sheet1.Cells(row, 5) = y2
    Sheet1.Cells(row, 6) = z2
    Sheet1.Cells(row, 7) = x3
    Sheet1.Cells(row, 8) = y3
    Sheet1.Cells(row, 9) = z3
End Sub

Public Sub read_stl()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim name As String
    Dim data() As Facet
 
    '------------------------------
    ChDir ThisWorkbook.Path
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
    If Dir(filename) = "" Then Exit Sub
 
    Call read_stl_binary(filename, name, data)
 
    '------------------------------
    Call SetRowTitle
 
    '法線ベクトルの表示 On/Off
    If False Then
        Sheet1.Cells(2, 10) = "nx"
        Sheet1.Cells(2, 11) = "ny"
        Sheet1.Cells(2, 12) = "nz"
    End If
 
    Sheet1.Cells(1, 1) = name
 
    For i = LBound(data) To UBound(data)
        Call SetRow(i + 3, data(i).v(0), data(i).v(1), data(i).v(2), data(i).v(3), data(i).v(4), data(i).v(5), data(i).v(6), data(i).v(7), data(i).v(8))
     
        '法線ベクトルの表示 On/Off
        If False Then
            Sheet1.Cells(i + 3, 10) = data(i).n(0)
            Sheet1.Cells(i + 3, 11) = data(i).n(1)
            Sheet1.Cells(i + 3, 12) = data(i).n(2)
        End If
    Next i
End Sub

'Binary形式のSTLファイルの書き出し
Public Sub write_stl_binary(filename As String, ByRef name As String, ByRef data() As Facet)
    Dim i As Long
    Dim buf() As Byte

    On Error GoTo Label1
 
    Open filename For Binary As 1
        '任意の80文字 (Asciiコードのみ対応)
        ReDim buf(79) As Byte
     
        For i = 0 To 79
            If i < Len(name) Then
                buf(i) = Asc(Mid(name, i + 1, 1))
            Else
                buf(i) = 0
            End If
        Next i
     
        Put 1, , buf
     
        '三角形の個数
        i = UBound(data) - LBound(data) + 1
        Put 1, , i
     
        ReDim buf(1) As Byte
        buf(0) = CByte(0)
        buf(1) = CByte(0)
     
        '三角形
        For i = LBound(data) To UBound(data)
            Put 1, , data(i).n
            Put 1, , data(i).v
            Put 1, , buf
        Next i
    Close 1
 
    Exit Sub
Label1:
    Close 1
    MsgBox "Error (write_stl_binary)", vbExclamation
End Sub

'Binary形式のSTLファイルの読み込み
Public Sub read_stl_binary(filename As String, ByRef name As String, ByRef data() As Facet)
    Dim i As Long
    Dim buf() As Byte
 
    On Error GoTo Label1
 
    Open filename For Binary As 1
        '任意の80文字 (Asciiコードのみ対応)
        ReDim buf(79) As Byte
        Get 1, , buf
     
        name = ""
     
        For i = 0 To 79
            If buf(i) = 0 Then Exit For
         
            name = name & Chr(buf(i))
        Next i
     
        '三角形の個数
        Get 1, , i
        ReDim data(i - 1) As Facet
     
        ReDim buf(1) As Byte
     
        '三角形
        For i = LBound(data) To UBound(data)
            Get 1, , data(i).n
            Get 1, , data(i).v
            Get 1, , buf
        Next i
    Close 1
 
    Exit Sub
Label1:
    Close 1
    MsgBox "Error (read_stl_binary)", vbExclamation
End Sub

Excelと3D Builderで遊ぼう 1

　最近知ったのですが、Windows10には標準で3D Builderというソフトが入っているらしいです。残念ながら、私のパソコンでは見つからなかったので、Microsoftのサイトからダウンロードしました。
　3D Builderを使うと簡単に3次元モデルを作ることができます。市販のソフトに比べると機能は限られているのでしょうが、ちょっと遊んでみるには十分です。面白そうなので、ちょっと遊んでみました。

　3次元モデルを保存するファイルの形式にはいくつかあるみたいですが、簡単そうだったので、STLファイルというのを使ってみます。STLファイルの中身はただの座標データの集まりなので、Excelマクロで簡単に見られます。
　今回のマクロは適当なSTLファイルの作成と読み込みをしています。

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



Option Explicit

'==================================================
'STLファイル (Standard Triangulated Language)
'ASCII形式とBinary形式がある
'Unicode対応が面倒だったので、今回のマクロはBinaryのみ
'==================================================
'STLファイル(ASCII形式)の構造
'<solid開始> + <三角形データ> + <三角形データ> + ... + <solid終了>
'スペース区切り
'--------------------------------------------------
'solid name
' facet normal nx ny nz
'  outer loop
'   vertex v1x v1y v1z
'   vertex v2x v2y v2z
'   vertex v3x v3y v3z
'  endloop
' endfacet
' ...
'endsolid name
'--------------------------------------------------
'nameは適当な文字列
'nx, v1x, etc.は浮動小数点数 (1.000000e+01)
'座標はプラスの値のみ
'--------------------------------------------------
'例 (以下をテキストファイルで保存して、拡張子をstlにすると、3D Builderで読み込める)
'solid test
' facet normal 0.0000e+00 0.0000e+00 1.0000e+00
'  outer loop
'   vertex 2.0000e+00 1.0000e+00 0.0000e+00
'   vertex 5.0000e-01 1.8660e+00 0.0000e+00
'   vertex 5.0000e-01 1.3397e-01 0.0000e+00
'  endloop
' endfacet
'endsolid
'==================================================
'STLファイル(Binary形式)の構造
'<ヘッダ部> + <三角形データ> + <三角形データ>...
'Little Endianでいいらしい
'--------------------------------------------------
'<ヘッダ部>
'header_string  80bytes 80文字の任意文字列
'num_triangle   4bytes  三角形の個数 (整数)
'<三角形のデータ>
'nx     4bytes 法線ベクトル X (浮動小数点数)
'ny     4bytes 法線ベクトル Y (浮動小数点数)
'nz     4bytes 法線ベクトル Z (浮動小数点数)
'v1x    4bytes 頂点1 X座標 (浮動小数点数)
'v1y    4bytes 頂点1 Y座標 (浮動小数点数)
'v1z    4bytes 頂点1 Z座標 (浮動小数点数)
'v2x    4bytes 頂点2 X座標 (浮動小数点数)
'v2y    4bytes 頂点2 Y座標 (浮動小数点数)
'v2z    4bytes 頂点1 Z座標 (浮動小数点数)
'v3x    4bytes 頂点3 X座標 (浮動小数点数)
'v3y    4bytes 頂点3 Y座標 (浮動小数点数)
'v3z    4bytes 頂点3 Z座標 (浮動小数点数)
'data   2bytes 未使用データ
'--------------------------------------------------
'法線ベクトルは頂点から計算できるはず
'nx = (v2y - v1y) * (v3z - v1z) - (v2z - v1z) * (v3y - v1y)
'ny = (v2z - v1z) * (v3x - v1x) - (v2x - v1x) * (v3z - v1z)
'nz = (v2x - v1x) * (v3y - v1y) - (v2y - v1y) * (v3x - v1x)
'--------------------------------------------------

Public Const PI = 3.1415926535

'三角形データ
Private Type Facet
    n(2) As Single
    v(8) As Single
End Type

'変数の大きさの確認
Private Sub VariableSize()
    Dim i As Integer
    Dim l As Long
    Dim s As Single
    Dim d As Double
 
    MsgBox "Size of Integer : " & Len(i) & vbCrLf _
        & "Size of Long : " & Len(l) & vbCrLf _
        & "Size of Single : " & Len(s) & vbCrLf _
        & "Size of Double : " & Len(d)
End Sub

'ファイルのダンプ
Public Sub dump()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim read_size As Long
    Dim read_offset As Long
    Dim buf() As Byte
 
    Sheet1.Cells.Clear
 
    '------------------------------
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
    If Dir(filename) = "" Then Exit Sub
 
    '------------------------------
    'データの読み込み
    read_size = 1024
    read_offset = 0
 
    ReDim buf(read_size - 1) As Byte
 
    Open filename For Binary As 1
        'オフセット
        For i = 0 To read_offset - 1
            Get 1, , buf(0)
        Next i
     
        'Seek 1, read_offset + 1
     
        Get 1, , buf
    Close 1
 
    '------------------------------
    'データの表示
    Sheet1.Cells(1, 1) = "File Name"
    Sheet1.Cells(1, 2) = filename
    Sheet1.Cells(2, 1) = "File Size"
    Sheet1.Cells(2, 2) = FileLen(filename)
    Sheet1.Cells(3, 1) = "Read Size"
    Sheet1.Cells(3, 2) = read_size
    Sheet1.Cells(4, 1) = "Read Offset"
    Sheet1.Cells(4, 2) = read_offset
 
    For i = 0 To read_size / 16 - 1
        For j = 0 To 15
            '10進数表示
            Sheet1.Cells(i + 6, j + 1) = buf(i * 16 + j)
         
            '16進数表示
            'Sheet1.Cells(i + 6, j + 1) = Hex(buf(i * 16 + j))
         
            '文字列表示
            'Sheet1.Cells(i + 6, j + 1) = Chr(buf(i * 16 + j))
        Next j
    Next i
 
    '------------------------------
    Erase buf
End Sub

'正八面体
Public Sub sample_stl()
    Dim filename As String
    Dim data(7) As Facet
 
    Call SetFacet(data(0), 0, 0, Math.Sqr(2), 1, -1, 0, 1, 1, 0)
    Call SetFacet(data(1), 0, 0, Math.Sqr(2), 1, 1, 0, -1, 1, 0)
    Call SetFacet(data(2), 0, 0, Math.Sqr(2), -1, 1, 0, -1, -1, 0)
    Call SetFacet(data(3), 0, 0, Math.Sqr(2), -1, -1, 0, 1, -1, 0)
    Call SetFacet(data(4), 0, 0, -Math.Sqr(2), 1, 1, 0, 1, -1, 0)
    Call SetFacet(data(5), 0, 0, -Math.Sqr(2), -1, 1, 0, 1, 1, 0)
    Call SetFacet(data(6), 0, 0, -Math.Sqr(2), -1, -1, 0, -1, 1, 0)
    Call SetFacet(data(7), 0, 0, -Math.Sqr(2), 1, -1, 0, -1, -1, 0)
 
    filename = ThisWorkbook.Path + "\sample.stl"
 
    If Dir(filename) <> "" Then Kill filename
 
    Call write_stl_binary(filename, "sample", data)
End Sub

Private Sub SetFacet(ByRef f As Facet, _
    x1 As Single, y1 As Single, z1 As Single, _
    x2 As Single, y2 As Single, z2 As Single, _
    x3 As Single, y3 As Single, z3 As Single)

    '------------------------------
    f.v(0) = x1
    f.v(1) = y1
    f.v(2) = z1
    f.v(3) = x2
    f.v(4) = y2
    f.v(5) = z2
    f.v(6) = x3
    f.v(7) = y3
    f.v(8) = z3
 
    '------------------------------
    '法線ベクトルの計算
    Dim temp(6) As Single
 
    temp(0) = f.v(3) - f.v(0)
    temp(1) = f.v(4) - f.v(1)
    temp(2) = f.v(5) - f.v(2)
    temp(3) = f.v(6) - f.v(0)
    temp(4) = f.v(7) - f.v(1)
    temp(5) = f.v(8) - f.v(2)
 
    f.n(0) = temp(1) * temp(5) - temp(2) * temp(4)
    f.n(1) = temp(2) * temp(3) - temp(0) * temp(5)
    f.n(2) = temp(0) * temp(4) - temp(1) * temp(3)
 
    temp(6) = Math.Sqr(f.n(0) * f.n(0) + f.n(1) * f.n(1) + f.n(2) * f.n(2))
 
    If temp(6) < 0.000000001 Then
        MsgBox "Error (SetFacet)"
        Exit Sub
    End If
 
    f.n(0) = f.n(0) / temp(6)
    f.n(1) = f.n(1) / temp(6)
    f.n(2) = f.n(2) / temp(6)
End Sub

Private Sub SetRowTitle()
    Sheet1.Cells.Clear
 
    Sheet1.Cells(2, 1) = "v1x"
    Sheet1.Cells(2, 2) = "v1y"
    Sheet1.Cells(2, 3) = "v1z"
    Sheet1.Cells(2, 4) = "v2x"
    Sheet1.Cells(2, 5) = "v2y"
    Sheet1.Cells(2, 6) = "v2z"
    Sheet1.Cells(2, 7) = "v3x"
    Sheet1.Cells(2, 8) = "v3y"
    Sheet1.Cells(2, 9) = "v3z"
End Sub

Private Sub SetRow(row As Long, _
    x1 As Single, y1 As Single, z1 As Single, _
    x2 As Single, y2 As Single, z2 As Single, _
    x3 As Single, y3 As Single, z3 As Single)

    Sheet1.Cells(row, 1) = x1
    Sheet1.Cells(row, 2) = y1
    Sheet1.Cells(row, 3) = z1
    Sheet1.Cells(row, 4) = x2
    Sheet1.Cells(row, 5) = y2
    Sheet1.Cells(row, 6) = z2
    Sheet1.Cells(row, 7) = x3
    Sheet1.Cells(row, 8) = y3
    Sheet1.Cells(row, 9) = z3
End Sub

Public Sub read_stl()
    Dim i As Long
    Dim j As Long
    Dim filename As String
    Dim name As String
    Dim data() As Facet
 
    '------------------------------
    ChDir ThisWorkbook.Path
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
    If Dir(filename) = "" Then Exit Sub
 
    Call read_stl_binary(filename, name, data)
 
    '------------------------------
    Call SetRowTitle
 
    '法線ベクトルの表示 On/Off
    If False Then
        Sheet1.Cells(2, 10) = "nx"
        Sheet1.Cells(2, 11) = "ny"
        Sheet1.Cells(2, 12) = "nz"
    End If
 
    Sheet1.Cells(1, 1) = name
 
    For i = LBound(data) To UBound(data)
        Call SetRow(i + 3, data(i).v(0), data(i).v(1), data(i).v(2), data(i).v(3), data(i).v(4), data(i).v(5), data(i).v(6), data(i).v(7), data(i).v(8))
     
        '法線ベクトルの表示 On/Off
        If False Then
            Sheet1.Cells(i + 3, 10) = data(i).n(0)
            Sheet1.Cells(i + 3, 11) = data(i).n(1)
            Sheet1.Cells(i + 3, 12) = data(i).n(2)
        End If
    Next i
End Sub

'Binary形式のSTLファイルの書き出し
Public Sub write_stl_binary(filename As String, ByRef name As String, ByRef data() As Facet)
    Dim i As Long
    Dim buf() As Byte

    On Error GoTo Label1
 
    Open filename For Binary As 1
        '任意の80文字 (Asciiコードのみ対応)
        ReDim buf(79) As Byte
     
        For i = 0 To 79
            If i < Len(name) Then
                buf(i) = Asc(Mid(name, i + 1, 1))
            Else
                buf(i) = 0
            End If
        Next i
     
        Put 1, , buf
     
        '三角形の個数
        i = UBound(data) - LBound(data) + 1
        Put 1, , i
     
        ReDim buf(1) As Byte
        buf(0) = CByte(0)
        buf(1) = CByte(0)
     
        '三角形
        For i = LBound(data) To UBound(data)
            Put 1, , data(i).n
            Put 1, , data(i).v
            Put 1, , buf
        Next i
    Close 1
 
    Exit Sub
Label1:
    Close 1
    MsgBox "Error (write_stl_binary)", vbExclamation
End Sub

'Binary形式のSTLファイルの読み込み
Public Sub read_stl_binary(filename As String, ByRef name As String, ByRef data() As Facet)
    Dim i As Long
    Dim buf() As Byte
 
    On Error GoTo Label1
 
    Open filename For Binary As 1
        '任意の80文字 (Asciiコードのみ対応)
        ReDim buf(79) As Byte
        Get 1, , buf
     
        name = ""
     
        For i = 0 To 79
            If buf(i) = 0 Then Exit For
         
            name = name & Chr(buf(i))
        Next i
     
        '三角形の個数
        Get 1, , i
        ReDim data(i - 1) As Facet
     
        ReDim buf(1) As Byte
     
        '三角形
        For i = LBound(data) To UBound(data)
            Get 1, , data(i).n
            Get 1, , data(i).v
            Get 1, , buf
        Next i
    Close 1
 
    Exit Sub
Label1:
    Close 1
    MsgBox "Error (read_stl_binary)", vbExclamation
End Sub

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

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