前回は、簡単な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
0 件のコメント:
コメントを投稿