读取stl格式的3D模型的VB的类（By:嗷嗷叫的老马）
这个类用于读取stl格式的3D模型（一种后缀是.stl的3D模型文件，这个和C++的stl库无关）stl格式的3D模型可以被几乎所有的3D软件加载，比如3dsmax或maya。
不保证有无BUG。可以用于研究stl的文件格式。
原作者：嗷嗷叫的老马
这是一个VB6的类，不是VB.NET的东西。
据说……这种格式不存储纹理坐标。VERSION 1.0 CLASS
BEGIN
MultiUse = -1'True
Persistable = 0'NotPersistable
DataBindingBehavior = 0'vbNone
DataSourceBehavior= 0'vbNone
MTSTransactionMode= 0'NotAnMTSObject
END
Attribute VB_Name = "cLoadSTL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Option Compare Text
'加载STL格式文件
'
'判断STL文件的格式(ASCII与BINARY),并读入内存
'
'By 嗷嗷叫的老马
'
Private Type MyFacet
PNX As Single '法向量
PNY As Single '法向量
PNZ As Single '法向量
P1X As Single '第一个顶点
P1Y As Single '第一个顶点
P1Z As Single '第一个顶点
P2X As Single '第一个顶点
P2Y As Single '第一个顶点
P2Z As Single '第一个顶点
P3X As Single '第一个顶点
P3Y As Single '第一个顶点
P3Z As Single '第一个顶点
FacetProperties As Integer'面片属性
End Type
Dim mFileName As String '文件名
Dim mDescriptionAs String '文件信息
Dim mData() As MyFacet '三角面片数据
Dim mFacetIndex As Long '当前索引
Dim mXMax As Single, mYMax As Single, mXMin As Single, mYMin As Single, mZMin As Single, mZMax As Single
Public Function LoadSTLFile(ByVal sFileName As String) As Long
Dim sBuff As String, sLBuff() As String, byteBuff() As Byte, mFacetCount As Long
Dim IsAscii As Boolean, DataIndex As Long, VIndex As Long
Dim Fn As Long, I As Long, J As Long, sTmp() As String
' On Error GoTo errH
LoadSTLFile = -1
If FileLen(sFileName) < 0 Then Exit Function
mFileName = sFileName
mXMax = -999
mXMin = 999
mYMax = -999
mYMin = 999
mZMax = -999
mZMin = 999
Fn = FreeFile
Open mFileName For Binary As #Fn
ReDim byteBuff(79)
Get #Fn, , byteBuff()
IsAscii = False
For I = 0 To 79
If byteBuff(I) = &HA Then
IsAscii = True
Exit For
End If
Next
' MsgBox IsAscii
If IsAscii = True Then 'ASCII格式包含换行符
'以ASCII格式读取数据
'
' solid OpenSCAD_Model '文件信息
' facet normal -1.000000 0.000000 0.000000 '一个三角面片开始,法向量坐标
' outer loop '开始描述三角面片顶点坐标
' vertex -25.000000 -29.250000 8.000000 '第一个点
' vertex -25.000000 -27.586706 7.825181 '第二个点
' vertex -25.000000 -30.913294 7.825181 '第三个点
' endloop '结束顶点描述
' endfacet '一个三角面片结束
' endsolid OpenSCAD_Model
sBuff = Space(LOF(1))
Get #Fn, 1, sBuff
sLBuff() = Split(Replace(sBuff, Chr(0), " "), vbLf)
' MsgBox "00"
mFacetCount = -1
mDescription = Replace(sLBuff(0), "solid ", "") '得到文件信息
' MsgBox "11"
For I = 1 To UBound(sLBuff)
sTmp() = Split(Trim(sLBuff(I)), " ")
For J = 0 To UBound(sTmp)
sTmp(J) = Trim(sTmp(J))
Next
If J > 0 Then
Select Case sTmp(0)
Case "facet" '一个三角面片开始,得到法向量坐标
mFacetCount = mFacetCount + 1
ReDim Preserve mData(mFacetCount)
With mData(mFacetCount)
.PNX = sTmp(2)
.PNY = sTmp(3)
.PNZ = sTmp(4)
End With
Case "outer" '描述三角面片顶点坐标
VIndex = 1
Case "vertex" '顶点坐标值
With mData(mFacetCount)
Select Case VIndex
Case 1
.P1X = sTmp(1)
.P1Y = sTmp(2)
.P1Z = sTmp(3)
Case 2
.P2X = sTmp(1)
.P2Y = sTmp(2)
.P2Z = sTmp(3)
Case 3
.P3X = sTmp(1)
.P3Y = sTmp(2)
.P3Z = sTmp(3)
Case Else
GoTo errH
End Select
VIndex = VIndex + 1
End With
Case "end" '结束顶点描述
Case "endfacet" '一个三角面片结束
Case "endsolid" '文件结束
End Select
End If
Next
' MsgBox "22"
Else
'以BINARY格式读取数据
mDescription = StrConv(byteBuff(), vbUnicode) '得到文件信息
mDescription = Trim(Replace(mDescription, Chr(0), " "))
Get #Fn, , mFacetCount
ReDim mData(mFacetCount - 1)
Get #Fn, , mData()
End If
For I = 0 To mFacetCount - 1
With mData(I)
If mXMax < .PNX Then mXMax = .PNX
If mXMin > .PNX Then mXMin = .PNX
If mYMax < .PNY Then mYMax = .PNY
If mYMin > .PNY Then mYMin = .PNY
If mZMax > .PNZ Then mZMax = .PNZ
If mZMin > .PNZ Then mZMin = .PNZ
If mXMax < .P1X Then mXMax = .P1X
If mXMin > .P1X Then mXMin = .P1X
If mYMax < .P1Y Then mYMax = .P1Y
If mYMin > .P1Y Then mYMin = .P1Y
If mZMax > .P1Z Then mZMax = .P1Z
If mZMin > .P1Z Then mZMin = .P1Z
If mXMax < .P2X Then mXMax = .P2X
If mXMin > .P2X Then mXMin = .P2X
If mYMax < .P2Y Then mYMax = .P2Y
If mYMin > .P2Y Then mYMin = .P2Y
If mZMax > .P2Z Then mZMax = .P2Z
If mZMin > .P2Z Then mZMin = .P2Z
If mXMax < .P3X Then mXMax = .P1X
If mXMin > .P3X Then mXMin = .P1X
If mYMax < .P3Y Then mYMax = .P3Y
If mYMin > .P3Y Then mYMin = .P3Y
If mZMax > .P3Z Then mZMax = .P3Z
If mZMin > .P3Z Then mZMin = .P3Z
End With
Next
LoadSTLFile = UBound(mData) + 1
errH:
Close #Fn
End Function
Public Function SaveSTLFile(ByVal FileName As String, ByVal IsAscii As Boolean) As Long
'保存当前数据为STL文件
'
Dim I As Long, J As Long, K As Long, sBuff() As String, LineUbound As Long, sTmp As String * 80
Dim Fn As Long
If IsAscii = True Then
LineUbound = (UBound(mData) + 1) * 7 + 2 - 1
ReDim sBuff(LineUbound)
sBuff(0) = "solid " & mDescription
sBuff(LineUbound) = "endsolid " & mDescription
For I = 1 To LineUbound - 1
With mData(J)
Select Case K
Case 0
sBuff(I) = "facet normal " & .PNX & " " & .PNY & " " & .PNZ
Case 1
sBuff(I) = " outer loop"
Case 2
sBuff(I) = " vertex " & .P1X & " " & .P1Y & " " & .P1Z
Case 3
sBuff(I) = " vertex " & .P2X & " " & .P2Y & " " & .P2Z
Case 4
sBuff(I) = " vertex " & .P3X & " " & .P3Y & " " & .P3Z
Case 5
sBuff(I) = " endloop"
Case 6
sBuff(I) = "endfacet"
K = -1
J = J + 1
End Select
K = K + 1
End With
Next
On Error Resume Next
Kill FileName
On Error GoTo 0
Fn = FreeFile
Open FileName For Binary As #Fn
Put #Fn, , Join(sBuff(), vbLf)
Close #Fn
Else
On Error Resume Next
Kill FileName
On Error GoTo 0
Fn = FreeFile
Open FileName For Binary As #Fn
sTmp = mDescription
I = UBound(mData) + 1
Put #Fn, , sTmp
Put #Fn, , I
Put #Fn, , mData()
Close #Fn
End If
SaveSTLFile = FileLen(FileName)
End Function
Public Sub MoveToPoint(ByVal oX As Single, ByVal oY As Single, ByVal oZ As Single)
'整体平移到指定的点
'
Dim I As Long
Dim XOffset As Single, YOffset As Single, ZOffset As Single '最终偏移量
XOffset = oX + mXMin + (mXMax - mXMin) / 2
YOffset = oY + mYMin + (mYMax - mYMin) / 2
ZOffset = 0 - mZMin
For I = 0 To FacetCount - 1
With mData(I)
.PNX = .PNX + XOffset
.PNY = .PNY + YOffset
.PNZ = .PNZ + ZOffset
.P1X = .P1X + XOffset
.P1Y = .P1Y + YOffset
.P1Z = .P1Z + ZOffset
.P2X = .P2X + XOffset
.P2Y = .P2Y + YOffset
.P2Z = .P2Z + ZOffset
.P3X = .P3X + XOffset
.P3Y = .P3Y + YOffset
.P3Z = .P3Z + ZOffset
End With
Next
End Sub
Public Sub Rotate(ByVal BaseAxis As Long, ByVal lDir As Long)
'整体90度翻转
'
'BaseAxis - 基于哪个轴翻转.0=X,1=Y,2=Z
'lDir - 翻转方向,正数=顺时针,否则逆时针
'
Dim I As Long, tmpVar As Single
Dim oX As Single, oY As Single, oZ As Single
Dim maxX As Single, minX As Single, maxY As Single, minY As Single, maxZ As Single, minZ As Single
For I = 0 To UBound(mData) '得到XYZ的范围
With mData(I)
If maxX < .P1X Then maxX = .P1X
If maxY < .P1Y Then maxY = .P1Y
If maxZ < .P1Z Then maxZ = .P1Z
If maxX < .P2X Then maxX = .P2X
If maxY < .P2Y Then maxY = .P2Y
If maxZ < .P2Z Then maxZ = .P2Z
If maxX < .P3X Then maxX = .P3X
If maxY < .P3Y Then maxY = .P3Y
If maxZ < .P3Z Then maxZ = .P3Z
If minX > .P1X Then minX = .P1X
If minY > .P1Y Then minY = .P1Y
If minZ > .P1Z Then minZ = .P1Z
If minX > .P2X Then minX = .P2X
If minY > .P2Y Then minY = .P2Y
If minZ > .P2Z Then minZ = .P2Z
If minX > .P3X Then minX = .P3X
If minY > .P3Y Then minY = .P3Y
If minZ > .P3Z Then minZ = .P3Z
End With
Next
oX = minX + (maxX - minX) / 2 '得到对象的中心点
oY = minY + (maxY - minY) / 2
oZ = minZ + (maxZ - minZ) / 2
For I = 0 To UBound(mData)
With mData(I)
Select Case BaseAxis
Case 0 '基于X,则翻转Z,Y,圆心为oZ,oY
Call RotatePoint(.P1Z, .P1Y, oZ, oY, lDir)
Call RotatePoint(.P2Z, .P2Y, oZ, oY, lDir)
Call RotatePoint(.P3Z, .P3Y, oZ, oY, lDir)
Call RotatePoint(.PNZ, .PNY, oZ, oY, lDir)
Case 1 '基于Y,则翻转X,Z,圆心为oX,oZ
Call RotatePoint(.P1X, .P1Z, oX, oZ, lDir)
Call RotatePoint(.P2X, .P2Z, oX, oZ, lDir)
Call RotatePoint(.P3X, .P3Z, oX, oZ, lDir)
Call RotatePoint(.PNX, .PNZ, oX, oZ, lDir)
Case 2 '基于Z,则翻转Y,X,圆心为oY,oX
Call RotatePoint(.P1Y, .P1X, oY, oX, lDir)
Call RotatePoint(.P2Y, .P2X, oY, oX, lDir)
Call RotatePoint(.P3Y, .P3X, oY, oX, lDir)
Call RotatePoint(.PNY, .PNX, oY, oX, lDir)
End Select
End With
Next
End Sub
Private Sub RotatePoint(ByRef X As Single, ByRef Y As Single, ByVal oX As Single, ByVal oY As Single, ByVal lDir As Long)
'对一个点进行90度旋转
'
Dim tX As Single, tY As Single
Dim tXBase As Long, tYBase As Long, PPos As Long, destPPos As Long
tX = X
tY = Y
tXBase = Abs(tX - oX) '得到绝对距离
tYBase = Abs(tY - oY) '得到绝对距离
If tX > oX And tY > oY Then '得到旋转前所在象限
PPos = 1
ElseIf tX > oX And tY < oY Then
PPos = 4
ElseIf tX < oX And tY > oY Then
PPos = 2
Else
PPos = 3
End If
'得到旋转后所在象限
If lDir > 0 Then '顺时针旋转
destPPos = PPos - 1
If destPPos = 0 Then destPPos = 4
Else '逆时针旋转
destPPos = PPos + 1
If destPPos = 5 Then destPPos = 1
End If
Select Case destPPos '得到绝对距离在这个象限中的运算方式
Case 1
Case 2
tXBase = -tXBase
Case 3
tXBase = -tXBase
tYBase = -tYBase
Case 4
tYBase = -tYBase
End Select
X = oX + tXBase '得出结果
Y = oY + tYBase
End Sub
Public Property Get FileName() As String
FileName = mFileName
End Property
Public Property Get FacetCount() As Long
On Error Resume Next
FacetCount = UBound(mData) + 1
End Property
Public Property Get FacetIndex() As Long
FacetIndex = mFacetIndex
End Property
Public Property Let FacetIndex(ByVal vNewValue As Long)
mFacetIndex = vNewValue
End Property
Public Property Get PN_X() As Single
PN_X = mData(mFacetIndex).PNX
End Property
Public Property Let PN_X(ByVal vNewValue As Single)
mData(mFacetIndex).PNX = vNewValue
End Property
Public Property Get PN_Y() As Single
PN_Y = mData(mFacetIndex).PNY
End Property
Public Property Let PN_Y(ByVal vNewValue As Single)
mData(mFacetIndex).PNY = vNewValue
End Property
Public Property Get PN_Z() As Single
PN_Z = mData(mFacetIndex).PNZ
End Property
Public Property Let PN_Z(ByVal vNewValue As Single)
mData(mFacetIndex).PNZ = vNewValue
End Property
Public Property Get P1_X() As Single
P1_X = mData(mFacetIndex).P1X
End Property
Public Property Let P1_X(ByVal vNewValue As Single)
mData(mFacetIndex).P1X = vNewValue
End Property
Public Property Get P1_Y() As Single
P1_Y = mData(mFacetIndex).P1Y
End Property
Public Property Let P1_Y(ByVal vNewValue As Single)
mData(mFacetIndex).P1Y = vNewValue
End Property
Public Property Get P1_Z() As Single
P1_Z = mData(mFacetIndex).P1Z
End Property
Public Property Let P1_Z(ByVal vNewValue As Single)
mData(mFacetIndex).P1Z = vNewValue
End Property
Public Property Get P2_X() As Single
P2_X = mData(mFacetIndex).P2X
End Property
Public Property Let P2_X(ByVal vNewValue As Single)
mData(mFacetIndex).P2X = vNewValue
End Property
Public Property Get P2_Y() As Single
P2_Y = mData(mFacetIndex).P2Y
End Property
Public Property Let P2_Y(ByVal vNewValue As Single)
mData(mFacetIndex).P2Y = vNewValue
End Property
Public Property Get P2_Z() As Single
P2_Z = mData(mFacetIndex).P2Z
End Property
Public Property Let P2_Z(ByVal vNewValue As Single)
mData(mFacetIndex).P2Z = vNewValue
End Property
Public Property Get P3_X() As Single
P3_X = mData(mFacetIndex).P3X
End Property
Public Property Let P3_X(ByVal vNewValue As Single)
mData(mFacetIndex).P3X = vNewValue
End Property
Public Property Get P3_Y() As Single
P3_Y = mData(mFacetIndex).P3Y
End Property
Public Property Let P3_Y(ByVal vNewValue As Single)
mData(mFacetIndex).P3Y = vNewValue
End Property
Public Property Get P3_Z() As Single
P3_Z = mData(mFacetIndex).P3Z
End Property
Public Property Let P3_Z(ByVal vNewValue As Single)
mData(mFacetIndex).P3Z = vNewValue
End Property 总结一下老马写的代码描述的stl的格式。
首先读取80个字节，如果这80个字节中有一个字节的值是0xa，说明是ascii编码的，否则是二进制。
如果是二进制的话，再往后读取4个字节，这是三角形面片的数量。
然后是三角形面片的数据。每个三角形面片包含了1个法向量，3个顶点坐标，都是3个float一组，可以看老马代码中的结构体表达的每个三角形面片数据的格式——就是那个结构体组成的数组。
然后就没有了。
此外如果是ascii编码的话就更简单了，用notepad++打开一目了然。 经过我自己的分析，我注意到以下：
1、如果是二进制格式，STL文件的开头应该是“STLEXP 物体名”。其后用零补足80个字节。
2、如果是ASCII模式，文件开头是“solid 物体名（换行）”因此“嗷嗷叫的老马”使用的判断方式是检查文件前80个字节是否有换行符（'\x0A'），如果有，说明是ASCII模式。
3、ASCII模式的STL文件，它的结构如下：
solid 第一个物体名
三角形1
三角形2
三角形3
三角形4
...
三角形N
endsolid 第一个物体名
solid 第二个物体名
三角形1
三角形2
...
三角形N
endsolid 第二个物体名
...
solid 第N个物体名
...
endsolid 第N个物体名
其中三角形表的结构如下：
facet normal 法线X 法线Y 法线Z
outer loop
vertex 顶点1X 顶点1Y 顶点1Z
vertex 顶点2X 顶点2Y 顶点2Z
vertex 顶点3X 顶点3Y 顶点3Z
endloop
endfacet
也就是说stl不包含纹理坐标。经过3dsmax测试它确实不能导出纹理坐标。
为了更好地描述stl文件，我用3dsmax建立了一个四棱锥，导出了一个ascii的stl文件和一个binary的stl文件。
ascii：solid Pyramid
facet normal 0.000000e+000 -8.944272e-001 4.472136e-001
outer loop
vertex 0.000000e+000 0.000000e+000 2.000000e+001
vertex -1.000000e+001 -1.000000e+001 0.000000e+000
vertex 1.000000e+001 -1.000000e+001 0.000000e+000
endloop
endfacet
facet normal 8.944272e-001 0.000000e+000 4.472136e-001
outer loop
vertex 0.000000e+000 0.000000e+000 2.000000e+001
vertex 1.000000e+001 -1.000000e+001 0.000000e+000
vertex 1.000000e+001 1.000000e+001 0.000000e+000
endloop
endfacet
facet normal 0.000000e+000 8.944272e-001 4.472136e-001
outer loop
vertex 0.000000e+000 0.000000e+000 2.000000e+001
vertex 1.000000e+001 1.000000e+001 0.000000e+000
vertex -1.000000e+001 1.000000e+001 0.000000e+000
endloop
endfacet
facet normal -8.944272e-001 0.000000e+000 4.472136e-001
outer loop
vertex 0.000000e+000 0.000000e+000 2.000000e+001
vertex -1.000000e+001 1.000000e+001 0.000000e+000
vertex -1.000000e+001 -1.000000e+001 0.000000e+000
endloop
endfacet
facet normal -0.000000e+000 0.000000e+000 -1.000000e+000
outer loop
vertex -1.000000e+001 -1.000000e+001 0.000000e+000
vertex 0.000000e+000 0.000000e+000 0.000000e+000
vertex 1.000000e+001 -1.000000e+001 0.000000e+000
endloop
endfacet
facet normal 0.000000e+000 0.000000e+000 -1.000000e+000
outer loop
vertex 1.000000e+001 -1.000000e+001 0.000000e+000
vertex 0.000000e+000 0.000000e+000 0.000000e+000
vertex 1.000000e+001 1.000000e+001 0.000000e+000
endloop
endfacet
facet normal 0.000000e+000 0.000000e+000 -1.000000e+000
outer loop
vertex 1.000000e+001 1.000000e+001 0.000000e+000
vertex 0.000000e+000 0.000000e+000 0.000000e+000
vertex -1.000000e+001 1.000000e+001 0.000000e+000
endloop
endfacet
facet normal 0.000000e+000 0.000000e+000 -1.000000e+000
outer loop
vertex -1.000000e+001 1.000000e+001 0.000000e+000
vertex 0.000000e+000 0.000000e+000 0.000000e+000
vertex -1.000000e+001 -1.000000e+001 0.000000e+000
endloop
endfacet
endsolid Pyramid
binary:
页:
[1]