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 Function
