Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long
#Else
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
#End If
Private mSW& 'time
Sub CATMain()
'file select
Dim path As String
path = SelectFile()
If path = vbNullString Then Exit Sub
'time
Call SW_Start
'face Vertex Ary
Dim faceVtxAry As Variant
faceVtxAry = GetFaceVertexAry(path)
If IsEmpty(faceVtxAry) Then Exit Sub
'new partdoc
Dim doc As PartDocument: Set doc = CATIA.Documents.Add("Part")
'create surface
Dim surffact As SurfaceFactory: Set surffact = New SurfaceFactory
Call surffact.SetPartDoc(doc)
Dim surfs As Collection
Set surfs = surffact.CreateSurfs(faceVtxAry)
Set surffact = Nothing
If surfs Is Nothing Then Exit Sub
'add surface
Call AddSurface(surfs, doc.Part.hybridBodies.Add())
'finish
Dim Msg As String
Msg = "Done (" & surfs.count & " / " & UBound(faceVtxAry) + 1 & ")" & _
vbNewLine & "time : " & SW_GetTime#() & "s"
MsgBox Msg
End Sub
'-- [Visual Polyhedra] format convert function --
'param:string
'return:ary(ary(double,double,double),~)
Private Function GetFaceVertexAry(ByVal path As String) As Variant
GetFaceVertexAry = Empty
Dim source As String
source = ReadFile(path)
Dim source_ary As Variant
source_ary = GroupBySection(source)
If IsEmpty(source_ary) Then
MsgBox "Failed to get setting value(Section)", vbExclamation
Exit Function
End If
Dim c_Section As String: c_Section = source_ary(0)
Dim v_Section As String: v_Section = source_ary(1)
Dim f_Section As String: f_Section = source_ary(2)
Dim cValue_Dic As Object
Set cValue_Dic = Get_CValue(c_Section)
If cValue_Dic Is Nothing Then
MsgBox "Failed to get setting value(Cxx =)", vbExclamation
Exit Function
End If
Dim vValue_Dic As Object
Set vValue_Dic = Get_VValue(v_Section, cValue_Dic)
If vValue_Dic Is Nothing Then
MsgBox "Failed to get setting value(Vxx =)", vbExclamation
Exit Function
End If
Dim face_pos_ary As Variant
face_pos_ary = Get_FValue(f_Section, vValue_Dic)
If IsEmpty(face_pos_ary) Then
MsgBox "Failed to get setting value(Faces)", vbExclamation
Exit Function
End If
GetFaceVertexAry = face_pos_ary
End Function
'param:string,object(Scripting.Dictionary)
'return:ary(ary(double,double,double),~)
Private Function Get_FValue(ByVal source As String, _
ByVal v_dic As Object) As Variant
Get_FValue = Empty
Dim key As String
key = "\{(.*?)\}"
Dim matches As Object
Set matches = GetMatches(source, key)
If matches.count < 1 Then
Exit Function
End If
Dim face_ary() As Variant
ReDim face_ary(matches.count)
Dim faceIdxs As Variant
Dim face_unit() As Variant
Dim face_count As Long: face_count = -1
Dim idx As Long
Dim match As Object
For Each match In matches
faceIdxs = Split(match.SubMatches(0), ",")
If UBound(faceIdxs) < 2 Then GoTo Continue
If Not IsNumericAry(faceIdxs) Then GoTo Continue
ReDim face_unit(UBound(faceIdxs))
For idx = 0 To UBound(faceIdxs)
key = "V" & Trim(faceIdxs(idx))
If Not v_dic.Exists(key) Then GoTo Continue
face_unit(idx) = strAry2NumAry(Split(v_dic(key), ","))
Next
face_count = face_count + 1
face_ary(face_count) = face_unit
Continue:
Next
If face_count < 0 Then Exit Function
ReDim Preserve face_ary(face_count)
Get_FValue = face_ary
End Function
'param:string,object(Scripting.Dictionary)
'return:object(Scripting.Dictionary)
Private Function Get_VValue(ByVal source As String, _
ByVal c_dic As Object) As Object
Set Get_VValue = Nothing
Dim txt As String: txt = Trim(source)
Dim reg As Object
Dim keyvar As Variant
Dim revval As Double
Dim keys As Variant
keys = c_dic.keys
Dim idx As Long
For idx = UBound(keys) To 0 Step -1
Set reg = GetReg("-" & keys(idx))
revval = CDbl(c_dic(keys(idx))) * -1
txt = reg.Replace(txt, CStr(revval))
Set reg = GetReg("\+?" & keys(idx))
txt = reg.Replace(txt, c_dic(keys(idx)))
Next
Set reg = Nothing
Dim key As String
key = "(V\d+) +=.(\((.*?)\))"
Dim matches As Object
Set matches = GetMatches(txt, key)
If matches.count < 1 Then
Exit Function
End If
Dim dic As Object
Set dic = InitDic()
Dim sub0 As String, sub2 As String
Dim sub2ary As Variant
Dim match As Object
For Each match In matches
sub0 = match.SubMatches(0)
sub2 = match.SubMatches(2)
If dic.Exists(sub0) Then GoTo Continue
sub2ary = Split(sub2, ",")
If UBound(sub2ary) < 2 Then GoTo Continue
If Not IsNumericAry(sub2ary) Then GoTo Continue
dic.Add Trim(sub0), Trim(sub2)
Continue:
Next
Set Get_VValue = dic
End Function
'param:string
'return:object(Scripting.Dictionary)
Private Function Get_CValue(ByVal source As String) As Object
Set Get_CValue = Nothing
Dim key As String
key = "(C\d+) +=.(-?([1-9][0-9]*|0)(\.[0-9]+)?)"
Dim matches As Object
Set matches = GetMatches(source, key)
If matches.count < 1 Then
Exit Function
End If
Dim dic As Object
Set dic = InitDic()
Dim sub0 As String, sub1 As String
Dim match As Object
For Each match In matches
sub0 = match.SubMatches(0)
sub1 = match.SubMatches(1)
If dic.Exists(sub0) Then GoTo Continue
If Not IsNumeric(sub1) Then GoTo Continue
dic.Add Trim(sub0), Trim(sub1)
Continue:
Next
If dic.count < 1 Then Exit Function
Set Get_CValue = dic
End Function
'param:string
'return:ary(c_Section, v_Section, f_Section)
Private Function GroupBySection(ByVal source As String) As Variant
GroupBySection = Empty
Dim NewLineCode As String
NewLineCode = GetNewLineCode(source)
If NewLineCode = vbNullString Then Exit Function
Dim source_ary As Variant
'source_ary = Split(source, vbNewLine & vbNewLine)
source_ary = Split(source, NewLineCode & NewLineCode)
If UBound(source_ary) < 2 Then Exit Function
Dim section(2) As Variant
Dim txt As String
Dim i As Long
For i = 0 To UBound(source_ary)
txt = UCase(Trim(source_ary(i)))
Select Case Left(txt, 1)
Case "C"
section(0) = section(0) & txt
Case "V"
section(1) = section(1) & txt
Case "F"
section(2) = section(2) & txt
End Select
Next
If IsEmpty(section(0)) Or _
IsEmpty(section(1)) Or _
IsEmpty(section(2)) Then Exit Function
GroupBySection = section
End Function
Private Function GetNewLineCode(ByVal source As String) As String
GetNewLineCode = vbNullString
Select Case True
Case InStr(source, vbCrLf) > 0
GetNewLineCode = vbCrLf
Case InStr(source, vbCr) > 0
GetNewLineCode = vbCr
Case InStr(source, vbLf) > 0
GetNewLineCode = vbLf
End Select
End Function
'-- support function --
Private Function SelectFile() As String
SelectFile = vbNullString
Dim path As String
Dim Msg As String: Msg = "Please select the file to import"
Dim SelectionType As String: SelectionType = "*.txt"
path = CATIA.FileSelectionBox(Msg, SelectionType, CatFileSelectionModeOpen)
If path = vbNullString Then Exit Function
If CATIA.FileSystem.FileExists(path) Then
SelectFile = path
End If
End Function
Private Sub AddSurface(ByVal surfLst As Collection, _
ByVal hBody As HybridBody)
Dim surf As AnyObject
For Each surf In surfLst
Call hBody.AppendHybridShape(surf)
Next
End Sub
Private Function strAry2NumAry(ByVal strAry As Variant) As Variant
Dim numAry() As Variant
ReDim numAry(UBound(strAry))
Dim idx As Long
For idx = 0 To UBound(strAry)
numAry(idx) = CDbl(strAry(idx))
Next
strAry2NumAry = numAry
End Function
Private Function IsNumericAry(ByVal ary As Variant) As Boolean
IsNumericAry = False
Dim idx As Long
For idx = 0 To UBound(ary)
If Not IsNumeric(ary(idx)) Then Exit Function
Next
IsNumericAry = True
End Function
'Dictionary
Private Function InitDic(Optional CompareMode As Long = vbBinaryCompare) _
As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = CompareMode
Set InitDic = dic
End Function
'Matches
Private Function GetMatches(ByVal source As String, _
ByVal key As String) As Object
Dim reg As Object
Set reg = GetReg(key)
Set GetMatches = reg.Execute(source)
Set reg = Nothing
End Function
'RegExp
Private Function GetReg(ByVal Pattern As String) As Object
Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
With reg
.Pattern = Pattern
.IgnoreCase = False
.Global = True
End With
Set GetReg = reg
End Function
'IO
Private Function GetFSO() As Object
Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function
Private Function ReadFile(ByVal path$) As Variant
With GetFSO.GetFile(path).OpenAsTextStream
ReadFile = .ReadAll
.Close
End With
End Function
'時間計測スタート
Private Sub SW_Start()
mSW = timeGetTime
End Sub
'計測取得
''' @return:Double(Unit:s)
Private Function SW_GetTime#()
SW_GetTime = IIf(mSW = 0, -1, (timeGetTime - mSW) * 0.001)
End FunctionOption Explicit
Private mDoc As PartDocument
Private mPt As Part
Private mFact As HybridShapeFactory
Private mAxis As AxisSystem
Private mRemoveLst As Collection '一時要素
Private mSurf_Vertex_dic As Object '頂点管理
Private mPoints As Collection '点
Private Sub Class_Initialize()
Set mDoc = Nothing
Set mAxis = Nothing
Set mRemoveLst = New Collection
Set mSurf_Vertex_dic = InitDic()
Set mPoints = New Collection
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Dim anyoj As AnyObject
For Each anyoj In mRemoveLst
mFact.DeleteObjectForDatum anyoj
Next
On Error GoTo 0
End Sub
'Set PartDocument
Public Sub SetPartDoc(ByRef doc As Document)
If Not TypeName(doc) = "PartDocument" Then
MsgBox "PartDocument Only!", vbExclamation
End If
Set mDoc = doc
Set mPt = mDoc.Part
Set mFact = mPt.HybridShapeFactory
Set mAxis = CreateAxis()
Set mSurf_Vertex_dic = InitDic()
'一時消す
End Sub
'Single
Public Function CreateSurf(ByVal vtx_ary As Variant) As HybridShapeSurfaceExplicit
If mDoc Is Nothing Then Exit Function
Set CreateSurf = Nothing
Dim vtx_count As Long
vtx_count = UBound(vtx_ary) + 1
'面の頂点数-不足分作成
If Not mSurf_Vertex_dic.Exists(vtx_count) Then
'Vertex
If vtx_count > mPoints.count Then
Call AddTmpPoint(vtx_count - mPoints.count)
End If
'Poly,Fill
Dim vertexOfNPattern As Collection
Set vertexOfNPattern = InitVertexOfNPattern(vtx_count)
Call mSurf_Vertex_dic.Add(vtx_count, vertexOfNPattern)
End If
Set CreateSurf = GetUpdateDatumSurf(vtx_ary)
End Function
'Multi
Public Function CreateSurfs(ByVal face_pnt_ary As Variant) As Collection
If mDoc Is Nothing Then Exit Function
Set CreateSurfs = Nothing
Dim lst As Collection
Set lst = New Collection
Dim res As AnyObject
Dim idx As Long
For idx = 0 To UBound(face_pnt_ary)
Set res = CreateSurf(face_pnt_ary(idx))
If Not res Is Nothing Then
Call lst.Add(res)
End If
Next
If lst.count > 0 Then
Set CreateSurfs = lst
Else
MsgBox "Could not create a surface."
End If
End Function
'****************
'Update&Datum
Private Function GetUpdateDatumSurf(ByVal vtx_ary As Variant) As HybridShapeSurfaceExplicit
Set GetUpdateDatumSurf = Nothing
Dim vtx_count As Long
vtx_count = UBound(vtx_ary) + 1
Dim idx As Long
For idx = 1 To vtx_count
Call mPoints(idx).SetCoordinates(vtx_ary(idx - 1))
Call mPt.UpdateObject(mPoints(idx))
Next
On Error GoTo err:
Dim vertexOfNPattern As Collection
Set vertexOfNPattern = mSurf_Vertex_dic(vtx_count)
Call mPt.UpdateObject(vertexOfNPattern(1))
Call mPt.UpdateObject(vertexOfNPattern(2))
Set GetUpdateDatumSurf = CreateSurfaceDatum(GetRef(vertexOfNPattern(2)))
Exit Function
err:
'Call DumpPos(vtx_ary)
End Function
'不足分点作成
Private Sub AddTmpPoint(ByVal count As Long)
Dim i As Long
For i = 1 To count
Call mPoints.Add(CreatePoint(i))
Next
End Sub
'N個の頂点分のPoly,Fill
Private Function InitVertexOfNPattern(ByVal count As Long) As Collection
Set InitVertexOfNPattern = Nothing
Dim lst As Collection
Set lst = New Collection
Dim poly As HybridShapePolyline
Set poly = CreatePolyline(count)
Call lst.Add(poly)
Dim fill As HybridShapeFill
Set fill = CreateFill(poly)
Call lst.Add(fill)
Set InitVertexOfNPattern = lst
End Function
'ﾃﾞｰﾀﾑ化
Private Function CreateSurfaceDatum(Ref As Reference) As HybridShapeSurfaceExplicit
Dim Datum As HybridShapeSurfaceExplicit
Set Datum = mFact.AddNewSurfaceDatum(Ref)
Call mPt.UpdateObject(Datum)
Set CreateSurfaceDatum = Datum
End Function
'ﾌｨﾙ作成
Private Function CreateFill(Sp As HybridShapePolyline) As HybridShapeFill
Dim fill As HybridShapeFill
Set fill = mFact.AddNewFill()
With fill
Call .AddBound(GetRef(Sp))
.Continuity = 1
End With
On Error Resume Next
Call mPt.UpdateObject(fill)
Set CreateFill = fill
Call mRemoveLst.Add(fill)
End Function
'折れ線作成
Private Function CreatePolyline(ByVal count As Long) As HybridShapePolyline
Dim poly As HybridShapePolyline
Set poly = mFact.AddNewPolyline()
Dim i As Long
For i = 1 To count
Call poly.InsertElement(GetRef(mPoints.Item(i)), i)
Next
poly.Closure = True
On Error Resume Next
Call mPt.UpdateObject(poly)
Set CreatePolyline = poly
Call mRemoveLst.Add(poly)
End Function
'点作成
Private Function CreatePoint(ByVal v As Double) As HybridShapePointCoord
Dim PointCoord As HybridShapePointCoord
Set PointCoord = mFact.AddNewPointCoord(v, v * v, 0#)
PointCoord.RefAxisSystem = GetRef(mAxis)
On Error Resume Next
Call mPt.UpdateObject(PointCoord)
Set CreatePoint = PointCoord
Call mRemoveLst.Add(PointCoord)
End Function
'座標系作成
Private Function CreateAxis() As Variant 'AxisSystem
Dim axis As Variant 'AxisSystem
Set axis = mPt.AxisSystems.Add()
With axis
.OriginType = catAxisSystemOriginByCoordinates
.PutOrigin Array(0#, 0#, 0#)
.XAxisType = catAxisSystemAxisByCoordinates
.PutXAxis Array(1#, 0#, 0#)
.YAxisType = catAxisSystemAxisByCoordinates
.PutYAxis Array(0#, 2#, 0#)
.ZAxisType = catAxisSystemAxisByCoordinates
.PutZAxis Array(0#, 0#, 1#)
.IsCurrent = False
End With
Call mPt.UpdateObject(axis)
Set CreateAxis = axis
Call mRemoveLst.Add(axis)
End Function
'ﾘﾌｧﾚﾝｽ取得
Private Function GetRef(ByVal oj As AnyObject) As Reference
Set GetRef = mPt.CreateReferenceFromObject(oj)
End Function
'Dictionary
Private Function InitDic(Optional CompareMode As Long = vbBinaryCompare) _
As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = CompareMode
Set InitDic = dic
End Function
Private Sub DumpPos(ByVal ary As Variant)
Debug.Print "********"
Dim i As Long
For i = 0 To UBound(ary)
Debug.Print Join(ary(i), " : ")
Next
End Sub
