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


3Dの文字モデリングマクロ6 - C#ATIA


'text3D VBA
Option Explicit

Const FontPartPath = "C:\temp\"
Const FontPartName = "E3DTEXT.CATPart"

Enum ThicknessDirectionType
    tNormal = True
    tLine = False
End Enum

Public WorkDoc As New Text3DDocContainer '作業用PartDoc
Private FontDoc As New Text3DDocContainer 'フォント用PartDoc
Private StringData As New Text3DStringContainer 'テキスト管理クラス
Public GuideData As New Text3DGuideItemContainer  'ガイドデータ
Public FontData As Object 'フォント辞書
Public DeleteObj As New Collection 'WorkDoc削除要素
Public DeleteItem As New Collection 'WorkDoc削除要素

Sub CATMain()
    Dim Msg As String 'MsgBox用
    Call GetWorkPart
    Call GetFontPart
    Call GetFontParam(FontDoc)
    Set FontData = CreateHashTable
    Call GetFontData(FontDoc)
    Msg = "ガイドカーブを選択して下さい / ESC-キャンセル"
    Call GuideData.SetGuideCurve(SelectItemReference(EdgeFilter, Msg))
    Call WorkDoc.CreateTempHybridBody("Text3D_temp")
    Call SelectEndPoint
    Msg = "サポート面を選択して下さい / ESC-キャンセル"
    Call GuideData.SetSupportFace(SelectItemReference(SurfFilter, Msg))
    If Not GuideData.IsCurveOnFace Then
        MsgBox ("ガイドカーブがサポート面上にありません")
    End If
    Msg = "利用可能文字は以下(小文字は大文字に変換します)" + vbCrLf
    Msg = Msg + "{" + GetAllFont(29) + "}"
    Call StringData.SetString(InputBox(Msg, "文字を入力してください"))
    Call StringData.SetCurveLength(GuideData.Length)
    Call StringData.CreateFontSurface
    CATIA.RefreshDisplay = True
    Msg = "向きを確認してください。反転しますか?" + vbCrLf
    Msg = Msg + "横方向に反転 : はい" + vbCrLf
    Msg = Msg + "縦方向に反転  : いいえ" + vbCrLf
    Msg = Msg + "このまま : 中止"
    Select Case MsgBox(Msg, vbYesNoCancel)
        Case vbYes
            Call StringData.AxisReverse("X")
        Case vbNo
            Call StringData.AxisReverse("Z")
        Case Else
     End Select
    Call WorkDoc.CreateWorkHybridBody("Text3D")
    Call StringData.CreateBoundary
    Msg = " -- 文字の押し出し方法を指定してください -- " + vbCrLf
    Msg = Msg + "押し出し方向を指定する : はい" + vbCrLf
    Msg = Msg + "サポート面に対して垂直にする : いいえ" + vbCrLf
    Msg = Msg + "キャンセル : 中止"
    Select Case MsgBox(Msg, vbYesNoCancel)
        Case vbYes
            StringData.ThicknessType = tLine
            Msg = "押し出し方向となる線を選択して下さい / ESC-キャンセル"
            StringData.NormalLine = SelectItemReference(ThicknessDirectionFilter, Msg)
        Case vbNo
            StringData.ThicknessType = tNormal
        Case Else
    End Select
    Call StringData.CreateTxtBody
End Sub

Private Sub GetFontData(Doc As Text3DDocContainer)
    Dim Fonts As HybridShapes
    Set Fonts = GetHybridBody(Doc, "fonts")
    Dim Shape As hybridShape
    Dim Surf As Text3DFontClass
    For Each Shape In Fonts
        If IsSurface(Shape) Then
            Set Surf = New Text3DFontClass
            If Surf.SetFont(Shape) Then
                Call FontDataAdd(Surf)
                Set Surf = Nothing
            End If
        End If
End Sub

Private Sub FontDataAdd(Surf As Text3DFontClass)
    If FontData.Exists(Surf.Char) Then Exit Sub
    Call FontData.Add(Surf.Char, Surf)
End Sub

Private Function IsSurface(Shape As hybridShape) As Boolean
    Dim oRef As Reference
    Set oRef = FontDoc.Part.CreateReferenceFromObject(Shape)
    IsSurface = IIf(FontDoc.HSFac.GetGeometricalFeatureType(oRef) = 5, True, False)
End Function

Private Function GetHybridBody(Doc As Text3DDocContainer, Name As String) As HybridShapes
    On Error Resume Next
        Set GetHybridBody = Doc.Part.HybridBodies.Item(Name).HybridShapes
        If (Err.Number <> 0) Then
            Call MsgBox("フォント用Partファイルの形状セット名を確認してください")
            Set GetHybridBody = Nothing
        End If
    On Error GoTo 0
End Function

Private Function CreateHashTable() As Object
    Set CreateHashTable = CreateObject("Scripting.Dictionary")
End Function

Private Sub GetFontParam(Doc As Text3DDocContainer)
    Call StringData.SetParameters(Doc.Params)
    If Not StringData.CanUseClass Then
        Call MsgBox("フォント用Partファイルのパラメータの設定が正しくありません")
    End If
End Sub

Private Sub GetFontPart()
    Dim Doc As Document
    Dim Path As String
    Path = FontPartPath + FontPartName
    If Not IsExistsFile(Path) Then
        Call MsgBox("フォント用Partファイルが見つかりません。 設定パスをチェックしてください")
    End If
    Set Doc = CATIA.Documents.Open(Path) 'ReadはNG
    Call FontDoc.SetDocument(Doc)
    Call WindowMinimized(FontPartName)
End Sub

Private Sub WindowMinimized(PartName)
    On Error Resume Next
        Dim CatWindow As SpecsAndGeomWindow
        Set CatWindow = CATIA.Windows.Item(PartName)
        CatWindow.WindowState = catWindowStateMinimized
    On Error GoTo 0
End Sub

Private Function IsExistsFile(Path As String) As Boolean
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    IsExistsFile = FSO.FileExists(Path)
    Set FSO = Nothing
End Function

Private Function GetAllFont(ByVal StrLength As Long) As String
    Dim TargetStr As String
    TargetStr = Join(FontData.Keys, "")
    Dim v As Variant
    Dim N As Long
    Dim i As Long
    N = 0 '初期化
    ReDim v(0 To Round(Len(TargetStr) / StrLength - 0.5, 0))
        For i = 1 To Len(TargetStr) Step StrLength
        v(N) = Mid(TargetStr, i, StrLength)
        N = N + 1
    GetAllFont = Join(v, vbCrLf)
End Function

Private Sub GetWorkPart()
    If CATIA.Documents.Count < 1 Then
        Call MsgBox("Partファイルが開かれていません")
    End If
    Call WorkDoc.SetDocument(CATIA.ActiveDocument)
    If Not WorkDoc.CanUseClass Then
        Call MsgBox("アクティブなファイルがPartファイルではありません")
    End If
End Sub

'作業用Part SelectElement2
Private Function SelectItemReference(Filter, Msg As String) As Text3DObjRefClass
    Dim Status As String
    Dim Sel 'As selection
    Set Sel = WorkDoc.Sel 'エラー回避の為
    With Sel
        Status = .SelectElement2(Filter, Msg, False)
        If Status = "Cancel" Then
            Call MsgBox("中止します")
        End If
        Dim ObjRef As New Text3DObjRefClass
        On Error Resume Next
            ObjRef.BrapRef = WorkDoc.Part.CreateReferenceFromBRepName( _
                    GetBrepName(.Item(1).Value.Name), .Item(1).Value.Parent)
            ObjRef.SelRef = .Item(1).Reference
            ObjRef.Obj = .Item(1).Value
            'End If
        On Error GoTo 0
    End With
    Set SelectItemReference = ObjRef
End Function

Private Function EdgeFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Edge"
    EdgeFilter = Ary
End Function

Private Function SurfFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Face"
    SurfFilter = Ary
End Function

Private Function EndPointFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "HybridShapePointOnCurve"
    EndPointFilter = Ary
End Function

Private Function ThicknessDirectionFilter() As Variant
    Dim Ary(2) As Variant
    Ary(0) = "Line"
    Ary(1) = "RectilinearMonoDimFeatEdge"
    Ary(2) = "RectilinearTriDimFeatEdge"
    ThicknessDirectionFilter = Ary
End Function

Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

Private Function CreatePointOnCurveFromPercent( _
                                CurveRef As Reference, _
                                Ratio As Long, _
                                Reverse As Boolean) As Text3DObjRefClass
    Dim PntOnCrv As HybridShapePointOnCurve
    Set PntOnCrv = WorkDoc.HSFac.AddNewPointOnCurveFromPercent(CurveRef, Ratio, Reverse)
    Call WorkDoc.Part.UpdateObject(PntOnCrv)
    Dim Pnt As New Text3DObjRefClass
    Pnt.Obj = PntOnCrv
    Set CreatePointOnCurveFromPercent = Pnt
    Call DeleteObj.Add(PntOnCrv)
End Function

Private Sub SetGraphicsSelectPoint(Pnt As Text3DObjRefClass)
    With WorkDoc.Sel
        Call .Clear
        Call .Add(Pnt.Obj)
        Call .VisProperties.SetSymbolType(4)
        Call .VisProperties.SetRealColor(0, 255, 0, 1)
        Call .Clear
    End With
End Sub

Sub ElementHide(Elm As Text3DObjRefClass)
    With WorkDoc.Sel
        Call .Clear
        Call .Add(Elm.Obj)
        Call .VisProperties.SetShow(catVisPropertyNoShowAttr)
        Call .Clear
    End With
End Sub

Private Sub SelectEndPoint()
    Dim StartPnt As Text3DObjRefClass
    Set StartPnt = CreatePointOnCurveFromPercent(GuideData.GuideCurve.BrapRef, 0, False)
    Call SetGraphicsSelectPoint(StartPnt)
    Call WorkDoc.TempHybridBody.AppendHybridShape(StartPnt.Obj)
    Dim EndPnt As Text3DObjRefClass
    Set EndPnt = CreatePointOnCurveFromPercent(GuideData.GuideCurve.BrapRef, 0, True)
    Call SetGraphicsSelectPoint(EndPnt)
    Call WorkDoc.TempHybridBody.AppendHybridShape(EndPnt.Obj)
    Dim SelPnt As Text3DObjRefClass
    Set SelPnt = SelectItemReference(EndPointFilter, "端点を選択して下さい / ESC-キャンセル")
    Select Case SelPnt.SelRef.DisplayName
        Case StartPnt.Obj.Name
        Case EndPnt.Obj.Name
            Call GuideData.ReversePoint
        Case Else
            MsgBox ("指定した端点が不適切です")
    End Select
    Call ElementHide(StartPnt)
    Call ElementHide(EndPnt)
End Sub

Function FontCopyPaste(C As Text3DCharClass) As Text3DObjRefClass
    With FontDoc.Sel
        Call .Clear
        Call .Add(FontData.Item(C.Char).Item)
        Call .Copy
    End With
    Dim Font As New Text3DObjRefClass
    With WorkDoc.Sel
        Call .Add(WorkDoc.TempHybridBody)
        Call .Paste
        Font.Obj = .Item(1).Value
    End With
    Set FontCopyPaste = Font
End Function

Sub ProEnd()
    Dim oAny As AnyObject
    On Error Resume Next
        For Each oAny In DeleteObj
            Call WorkDoc.HSFac.DeleteObjectForDatum(oAny)
        With WorkDoc.Sel
            Call .Clear
            Call .Add(WorkDoc.TempHybridBody)
            For Each oAny In DeleteItem
                Call .Add(oAny)
            Call .Delete
        End With
        Call FontDoc.Doc.Close
        Set WorkDoc = Nothing
        Set FontDoc = Nothing
        Set StringData = Nothing
        Set FontData = Nothing
    On Error GoTo 0
End Sub


Const FontPartPath = "C:\temp\"
Const FontPartName = "E3DTEXT.CATPart"