こちらの続きです。
今更、3DDXFのインポートに挑む1 - C#ATIA
結構なボリュームになってしまったので、全てはこちらのサイトにUpしています。
GrabCAD - CAD library
全てを取り込むとこんな感じです。
前回に続いて、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
ちっともお手軽じゃ無いですね・・・。
大き目のデータをツールバー登録して実行した結果です。
元データじは、CX500の "rear_tyre" で11430枚の読み込みが
2分強ぐらいです。
マクロの実行(オペレーションが奪われている)時間が2分は耐えられますかね?
(個人的にはムリ)
よく調べていないのですが、失敗した8枚は3~4点の距離が
短すぎる為では無いかと思います。(面として成立しない)