×
INTELLIGENT WORK FORUMS
FOR ENGINEERING PROFESSIONALS

Log In

Come Join Us!

Are you an
Engineering professional?
Join Eng-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!
  • Students Click Here

*Eng-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Students Click Here

Jobs

draw with a catia all the Dual Geodesic Icosahedra

draw with a catia all the Dual Geodesic Icosahedra

RE: draw with a catia all the Dual Geodesic Icosahedra


Actually using the text files (http://dmccooey.com/polyhedra/DualGeodesicIcosahed...) would help build the geometry with a code that would read the file and build all vertices, edges, faces... no need for math logic.

Eric N.
indocti discant et ament meminisse periti

RE: draw with a catia all the Dual Geodesic Icosahedra

(OP)

RE: draw with a catia all the Dual Geodesic Icosahedra

Rugge, how did you format the text file?

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

thx Rugge, one more Q: my preview shows nice flat surfaces, however once pressing ok, my meshed surface gets rounded off... there arn't that many options to fiddle with sooo... whatamidoingwrong?

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

found it! tools options-DSE, Display Modes, Mesh "Flat"

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

Because it was a very interesting theme, I creating a macro.

1. Please put "Visual_Polyhedra_Import.bas" and "SurfaceFactory.cls" in the same project.
The entry point is "CATMain ()" of "Visual_Polyhedra_Import.bas".

2.For each data of WEB site "Visual Polyhedra"
Please save coordinates as a text file and load it with macro.
http://dmccooey.com/polyhedra/

3.After starting the macro, please select coordinate text data.

There are surfaces that fail to be created.
The reason is that the boundary of the surface is self-intersecting,
so it is impossible to create a fill surface.

In order to shorten processing time, creation of instances is minimized.

・Visual_Polyhedra_Import.bas

CODE --> vba

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 

・SurfaceFactory.cls

CODE --> vba

Option 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 

The tested data and macro file
Here it is.
Link

RE: draw with a catia all the Dual Geodesic Icosahedra

Kantoku, could you pls. attach an example of a correctly formatted txt file?...

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

(OP)
thankyou kantoku
wow I have to try

RE: draw with a catia all the Dual Geodesic Icosahedra

Hi.LWolf



1. Click "coordinates" to open the link.
2. Right click and save as a name.

RE: draw with a catia all the Dual Geodesic Icosahedra

thank you. I still get the message "could not create a surface"... any idea why?

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

Some of the data I tried represented one that expressed the star surface with 5 vertices.

Those whose boundaries of one surface self-intersect can not be imported because fill surface can not be created.

Please try with this text file.
https://files.engineering.com/getfile.aspx?folder=...

RE: draw with a catia all the Dual Geodesic Icosahedra

sorry, still "could not create a surface" message...

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

I can not understand the cause.
It is the environment tested here.
· OS: Win7 Pro sp1 64bit
· CATIA V5 R2015 (R25) SP4 HF64

Please execute the attached macro.
After execution, in the same folder as the text file
Since "dump.txt" is completed, please attach the file.
(It may be the reason that encoding does not go well ...)

https://files.engineering.com/getfile.aspx?folder=...

RE: draw with a catia all the Dual Geodesic Icosahedra

Hi LWolf.

It seems that coordinate values can be acquired.
What package are you using?
There is a possibility that the license for perhaps operation of the surface is insufficient.

RE: draw with a catia all the Dual Geodesic Icosahedra

Catia V5R26.4.38 I have access to quite a lot of Workbenches... some are shareable though. Which ones should I have?

regards,
LWolf

RE: draw with a catia all the Dual Geodesic Icosahedra

Excuse me.
I think that it is possible if GSD is probably available.
The command you are using is 'Point' 'Polyline' 'Fill Surface'.

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Eng-Tips Forums free from inappropriate posts.
The Eng-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Eng-Tips forums is a member-only feature.

Click Here to join Eng-Tips and talk with other members!


Resources


Close Box

Join Eng-Tips® Today!

Join your peers on the Internet's largest technical engineering professional community.
It's easy to join and it's free.

Here's Why Members Love Eng-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close