↑タイトル詐欺 主にCATIA V5 の VBA


今更、3DDXFのインポートに挑む1 - C#ATIA

GrabCAD - CAD library



'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)
    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)
    Set mCatState = State
    Set mAxis = CreateAxis
    Dim i As Long
    For i = 0 To BasePointCount - 1
        Call mPoints.Add(CreatePoint(i))
    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))
    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)
    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

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
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データ座標スケール?
    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)
    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)
    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
    On Error GoTo 0
    Set GetSuccessFace = Faces
    Set FacePnt = Nothing
    Set Face = Nothing
    Set Faces = Nothing
    Set BaseObj = Nothing
End Function

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
    Set Get3DFACE = Faces
End Function

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
        If Pos.CanExecute Then
            Call FacePnts.Push(Pos)
            Set Pos = Nothing
        End If
    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枚の読み込みが