C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

今更、3DDXFのインポートに挑む2

こちらの続きです。
今更、3DDXFのインポートに挑む1 - C#ATIA

結構なボリュームになってしまったので、全てはこちらのサイトにUpしています。
GrabCAD - CAD library

全てを取り込むとこんな感じです。
f:id:kandennti:20160217185519p:plain

前回に続いて、Catiaのドキュメント・パート等を保持しているクラスです。

'VBA CatPartContainer.cls
Option Explicit
'メンバ
Private mDoc As PartDocument
Private mPart As Part
Private mHSFac As HybridShapeFactory
Private mWorkHBody As HybridBody

Private Sub Class_Terminate()
    On Error Resume Next
        Set mDoc = Nothing
        Set mPart = Nothing
        Set mHSFac = Nothing
        Set mWorkHBody = Nothing
    On Error GoTo 0
End Sub

Public Sub SetDocument(ByVal Doc As Document)
    If Not TypeName(Doc) = "PartDocument" Then
        Set mDoc = Nothing
        Exit Sub
    End If
    Set mDoc = Doc
    Set mPart = mDoc.Part
    Set mHSFac = mPart.HybridShapeFactory
End Sub

Property Get Doc() As PartDocument
    Set Doc = mDoc
End Property

Property Get Part() As Part
    Set Part = mPart
End Property

Property Get HSFac() As HybridShapeFactory
    Set HSFac = mHSFac
End Property

Public Sub AddWorkHBody(Optional Name As String)
    Set mWorkHBody = mPart.HybridBodies.Add
    If Len(Name) > 0 Then
        mWorkHBody.Name = Name
    End If
End Sub

Property Set WorkHBody(ByVal HB As HybridBody)
    Set mWorkHBody = HB
End Property

Property Get WorkHBody() As HybridBody
    Set WorkHBody = mWorkHBody
End Property

Public Function CanExecute() As Boolean
    CanExecute = IIf(Doc Is Nothing, False, True)
End Function

次に点・線・面を作ったり保持しているクラスです。

'VBA CatGeometryContainer.cls
Option Explicit
'メンバ
Private mCatState As CatPartContainer
Private mAxis As AxisSystem
Private mPoints As Collection
Private mTrianglePoly As HybridShapePolyline
Private mSquarePoly As HybridShapePolyline
Private mTriangleFill As HybridShapeFill
Private mSquareFill As HybridShapeFill
Private Const BasePointCount = 4

Private Sub Class_Initialize()
    Set mPoints = New Collection
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    With mCatState.HSFac
        .DeleteObjectForDatum mSquareFill
        .DeleteObjectForDatum mTriangleFill
        .DeleteObjectForDatum mSquarePoly
        .DeleteObjectForDatum mTrianglePoly
        .DeleteObjectForDatum GetRef(mAxis)
        Dim i As Long
        For i = 1 To BasePointCount
            .DeleteObjectForDatum mPoints.Item(i)
        Next
    End With
    Set mCatState = Nothing
    Set mAxis = Nothing
    Set mPoints = Nothing
    Set mTrianglePoly = Nothing
    Set mSquarePoly = Nothing
    Set mTriangleFill = Nothing
    Set mSquareFill = Nothing
    On Error GoTo 0
End Sub

Public Sub SetState(State As CatPartContainer)
    'Catia
    Set mCatState = State
    '座標系
    Set mAxis = CreateAxis
    '点
    Dim i As Long
    For i = 0 To BasePointCount - 1
        Call mPoints.Add(CreatePoint(i))
    Next
    Set mTrianglePoly = CreatePolyline(3)
    Set mSquarePoly = CreatePolyline(4)
    Set mTriangleFill = CreateFill(mTrianglePoly)
    Set mSquareFill = CreateFill(mSquarePoly)
End Sub

'データム化されたフィル取得
Public Function GetFace(ByVal FaceDxf As Face3DDXF, _
                        ByVal Scl As Double) _
                        As HybridShapeSurfaceExplicit
    '点更新
    Dim AryPos As Collection
    Set AryPos = FaceDxf.GetPointAry(Scl)
    Dim i As Long
    For i = 1 To AryPos.Count
        Call mPoints.Item(i).SetCoordinates(AryPos.Item(i))
        Call mCatState.Part.UpdateObject(mPoints.Item(i))
    Next
    '折れ線・フィル更新
    On Error Resume Next
    With mCatState.Part
        Select Case AryPos.Count
            Case 3
                Call .UpdateObject(mTrianglePoly)
                Call .UpdateObject(mTriangleFill)
                Set GetFace = CreateSurfaceDatum(GetRef(mTriangleFill))
            Case 4
                Call .UpdateObject(mSquarePoly)
                Call .UpdateObject(mSquareFill)
                Set GetFace = CreateSurfaceDatum(GetRef(mSquareFill))
                'Debug.Print "Square"
            Case Else
                'Debug.Print "err-point:" + CStr(FaceDxf.Count)
                Set GetFace = Nothing
        End Select
    End With
    On Error GoTo 0
    Set AryPos = Nothing
End Function

'データム化
Private Function CreateSurfaceDatum(Ref As Reference) As HybridShapeSurfaceExplicit
    Dim Datum As HybridShapeSurfaceExplicit
    Set Datum = mCatState.HSFac.AddNewSurfaceDatum(Ref)
    Call mCatState.Part.UpdateObject(Datum)
    Set CreateSurfaceDatum = Datum
    Set Datum = Nothing
End Function

'フィル作成
Private Function CreateFill(Sp As HybridShapePolyline) As HybridShapeFill
    Dim Fill As HybridShapeFill
    Set Fill = mCatState.HSFac.AddNewFill()
    With Fill
        Call .AddBound(GetRef(Sp))
        .Continuity = 1
    End With
    Call mCatState.Part.UpdateObject(Fill)
    Set CreateFill = Fill
    Set Fill = Nothing
End Function

'折れ線作成
Private Function CreatePolyline(ByVal Count As Long) As HybridShapePolyline
    Dim Poly As HybridShapePolyline
    Set Poly = mCatState.HSFac.AddNewPolyline()
    Dim i As Long
    For i = 1 To Count
        Call Poly.InsertElement(GetRef(mPoints.Item(i)), i)
    Next
    Poly.Closure = True
    Call mCatState.Part.UpdateObject(Poly)
    Set CreatePolyline = Poly
    Set Poly = Nothing
End Function

'点作成
Private Function CreatePoint(ByVal v As Double) As HybridShapePointCoord
    Dim PointCoord As HybridShapePointCoord
    Set PointCoord = mCatState.HSFac.AddNewPointCoord(v, v * v, 0#)
    PointCoord.RefAxisSystem = GetRef(mAxis)
    Call mCatState.Part.UpdateObject(PointCoord)
    Set CreatePoint = PointCoord
    Set PointCoord = Nothing
End Function

'座標系作成
Private Function CreateAxis() As AxisSystem
    Dim Axis As Variant 'AxisSystem
    Set Axis = mCatState.Part.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 mCatState.Part.UpdateObject(Axis)
    Set CreateAxis = Axis
    Set Axis = Nothing
End Function

'リファレンス取得
Public Function GetRef(ByVal Oj As AnyObject) As Reference
    Set GetRef = mCatState.Part.CreateReferenceFromObject(Oj)
End Function

次にシステムメニューを表示させる為のモジュールです。
基本的にこちらの物と同じです。
マクロを高速に実行させる(非公式) - C#ATIA

'VBA WinAPIMouse.bas
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  
Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
    (ByVal Hwnd As Long, ByVal msg As Long, _
     ByVal wParam As Long, ByVal lParam As Long) As Long

'Windows APIの構造体の定義
Public Type POINT
  X As Long
  Y As Long
End Type

'マウスポインタ関係のAPI
Public Declare Function GetCursorPos Lib "user32" _
                          (lpPoint As POINT) As Long
Public Declare Function SetCursorPos Lib "user32" _
                          (ByVal X As Long, ByVal Y As Long) As Long
                          
'マウスボタン関係のAPI
Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, _
                                      ByVal dx As Long, ByVal dy As Long, _
                                      ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Const MOUSEEVENTF_LEFTUP As Integer = &H4      '左ボタンUP
Private Const MOUSEEVENTF_LEFTDOWN As Integer = &H2    '左ボタンDown
Private Const MOUSEEVENTF_RIGHTUP As Integer = &H10    '右ボタンUP
Private Const MOUSEEVENTF_RIGHTDOWN As Integer = &H8   '右ボタンDown

Public Sub MouseRIGHT(ByVal posLeft As Long, ByVal posTop As Long)
    '右クリック
    Call SetCursorPos(posLeft, posTop)
    Call mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0)
    Call mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0)
End Sub

Public Sub MouseLEFT(ByVal posLeft As Long, ByVal posTop As Long)
    '左クリック
    Call SetCursorPos(posLeft, posTop)
    Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
    Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
End Sub

最後にメインとなるモジュールです。

'VBA Dxf3DInport.bas
Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Sub CATMain()
    'インポートファイル選択
    Dim FilePath As String
    FilePath = CATIA.FileSelectionBox("インポートファイルを選択", "*.DXF", CatFileSelectionModeOpen)
    If Len(FilePath) < 1 Then Exit Sub
    
    '設定
    Dim t As Long: t = timeGetTime
    Dim Scl As Double: Scl = 1000# 'DXFデータ座標スケール?
    
    'Catia関連取得
    Dim CatState As CatPartContainer: Set CatState = New CatPartContainer
    Call CatState.SetDocument(CATIA.ActiveDocument)
    If Not CatState.CanExecute Then
        MsgBox "Partファイルをアクティブにしてください"
        Exit Sub
    End If
    
    'ファイルの読み込み
    Dim Dxf As String
    Dxf = LoadFile(FilePath)
    If IsEmpty(Dxf) Then Exit Sub
    
    '座標抽出
    Dim FacePnts As Collection
    Set FacePnts = Get3DFACE(Dxf)
    Debug.Print "Get3DFACE:" + CStr(CDbl(timeGetTime - t) / 1000)
    
    'データム面取得
    Dim Faces As Collection
    Set Faces = GetSuccessFace(CatState, FacePnts, Scl)
    Debug.Print "GetSuccessFace:" + CStr(CDbl(timeGetTime - t) / 1000)
    
    '形状セット挿入
    Call AddFace(CatState, Faces)
    CatState.Part.Update
    Debug.Print "AddFace:" + CStr(CDbl(timeGetTime - t) / 1000)
    
    'レポート表示
    Dim Report As String: Report = "Time : " + CStr(CDbl(timeGetTime - t) / 1000) + " s" + vbNewLine
    Report = Report + "Inport/ALL : " + CStr(Faces.Count) + "/" + CStr(FacePnts.Count)
    MsgBox Report
    
    'お掃除
    Set CatState = Nothing
    Set FacePnts = Nothing
    Set Faces = Nothing
End Sub

'形状セットへ挿入
Private Sub AddFace(ByVal State As CatPartContainer, ByVal Faces As Collection)
    Call State.AddWorkHBody("3DDXF_Inport")
    CATIA.RefreshDisplay = False
    Dim MousePos As WinAPIMouse.POINT: MousePos = ShowSystemMenu '要らないかも
    Dim Face As HybridShapeSurfaceExplicit
    For Each Face In Faces
        Call State.WorkHBody.AppendHybridShape(Face)
    Next
    Call HideSystemMenu(MousePos) '要らないかも
    CATIA.RefreshDisplay = True
    Set Face = Nothing
End Sub

'データム面作成
Private Function GetSuccessFace(ByVal State As CatPartContainer, _
                                ByVal FacePnts As Collection, _
                                ByVal Scl As Double) As Collection
    'ベースオブジェクトの作成
    Dim BaseObj As CatGeometryContainer
    Set BaseObj = New CatGeometryContainer
    Call BaseObj.SetState(State)
    
    'データム面作成
    Dim FacePnt As Face3DDXF
    Dim Face As HybridShapeSurfaceExplicit
    Dim Faces As New Collection
    On Error Resume Next
        For Each FacePnt In FacePnts
            Set Face = BaseObj.GetFace(FacePnt, Scl)
            If Not Face Is Nothing Then
                Faces.Add Face
            End If
        Next
    On Error GoTo 0
    Set GetSuccessFace = Faces
    Set FacePnt = Nothing
    Set Face = Nothing
    Set Faces = Nothing
    Set BaseObj = Nothing
End Function

'DXFデータから座標郡取得
Private Function Get3DFACE(ByVal Txt As String) As Collection
    Dim Ary3DFACE As Variant
    Ary3DFACE = Split(Txt, "3DFACE")
    Dim i As Long
    Dim Faces As Collection: Set Faces = New Collection
    Dim Face As Face3DDXF
    For i = 1 To UBound(Ary3DFACE)
        Set Face = Get3DPosition(Ary3DFACE(i))
        If Not Face Is Nothing Then
            Faces.Add Face
        End If
    Next
    Set Get3DFACE = Faces
End Function

'1枚分の座標取得
Private Function Get3DPosition(ByVal Txt As String) As Face3DDXF
    Dim Ary As Variant: Ary = Split(Txt, GetLineFeedCord(Txt))
    Dim i As Long, Pnt As Long, XYZ As Long
    Dim FacePnts As Face3DDXF: Set FacePnts = New Face3DDXF
    For Pnt = 0 To 3
        Dim Pos As Pnt3DDXF: Set Pos = New Pnt3DDXF
        For i = 1 To UBound(Ary) Step 2
            For XYZ = 10 To 30 Step 10
                If InStr(Ary(i), CStr(XYZ + Pnt)) > 0 Then
                    If IsNumeric(Ary(i + 1)) Then
                        Call Pos.SetPosition(XYZ, CDbl(Ary(i + 1)))
                    End If
                End If
            Next
        Next
        If Pos.CanExecute Then
            Call FacePnts.Push(Pos)
            Set Pos = Nothing
        End If
    Next
    Set Get3DPosition = IIf(FacePnts.Count = 3 Or 4, FacePnts, Nothing)
End Function

'改行コード判断
Private Function GetLineFeedCord(ByVal s As String) As String
    Dim sss As String
    Select Case True
        Case InStr(s, vbCr) > 0
            GetLineFeedCord = vbCr
        Case InStr(s, vbLf) > 0
            GetLineFeedCord = vbLf
        Case InStr(s, vbCrLf) > 0
            GetLineFeedCord = vbNewLine
    End Select
End Function

'ファイルの読み込み
Private Function LoadFile(ByVal FilePath As String) As String
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not UCase(FSO.GetExtensionName(FilePath)) = "DXF" Then
        MsgBox "指定ファイルが、DXFファイルではありません"
        LoadFile = Empty: Exit Function
    End If
    If Not UCase(FSO.FileExists(FilePath)) Then
        MsgBox "指定ファイルが、ありません"
        LoadFile = Empty: Exit Function
    End If
    Dim Ts As Object: Set Ts = FSO.OpenTextFile(FilePath)
    LoadFile = UCase(Ts.ReadAll)
    Set Ts = Nothing
    Set FSO = Nothing
End Function

'システムメニュー表示 ひょっとしたら高速化するかも
Private Function ShowSystemMenu() As WinAPIMouse.POINT
    Dim StartPos As WinAPIMouse.POINT
    Call WinAPIMouse.GetCursorPos(StartPos)
    Call WinAPIMouse.MouseRIGHT(CATIA.Left + 10, CATIA.Top + 10)
    ShowSystemMenu = StartPos
End Function

'システムメニュー非表示
Private Sub HideSystemMenu(StartPos As WinAPIMouse.POINT)
    Call WinAPIMouse.MouseLEFT(StartPos.X, StartPos.Y)
End Sub

ちっともお手軽じゃ無いですね・・・。

大き目のデータをツールバー登録して実行した結果です。
f:id:kandennti:20160217185602p:plain
元データじは、CX500の "rear_tyre" で11430枚の読み込みが
2分強ぐらいです。
マクロの実行(オペレーションが奪われている)時間が2分は耐えられますかね?
(個人的にはムリ)

よく調べていないのですが、失敗した8枚は3~4点の距離が
短すぎる為では無いかと思います。(面として成立しない)