2020年7月7日火曜日

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

0 件のコメント:

コメントを投稿