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
0 件のコメント:
コメントを投稿