C#ATIA

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

3Dの文字モデリングマクロ7

こちらの続きです。
3Dの文字モデリングマクロ6 - C#ATIA

最後にCATMainメソッドを持つ、Text3D_Startモジュールです。

'text3D VBA
'Text3D_Start
Option Explicit

'フォント用Partファイルパス-この部分は各自設定してください
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用
    '各Part設定
    Call GetWorkPart
    Call GetFontPart
    Call GetFontParam(FontDoc)
    
    'フォント読み込み
    Set FontData = CreateHashTable
    Call GetFontData(FontDoc)
    
    WorkDoc.Doc.Activate
    
    'ガイドカーブ指定
    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 ("ガイドカーブがサポート面上にありません")
        ProEnd
    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
            ProEnd
    End Select
     
    'Body作成
    Call StringData.CreateTxtBody
     
    '終了
    ProEnd
End Sub

'***フォントPart関連***
'フォント面の取得
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
    Next
End Sub

'重複を避けてFontDataに登録
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
            ProEnd
        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ファイルのパラメータの設定が正しくありません")
        ProEnd
    End If
End Sub

'フォント用Partファイル設定
Private Sub GetFontPart()
    Dim Doc As Document
    
    Dim Path As String
    Path = FontPartPath + FontPartName
    If Not IsExistsFile(Path) Then
        Call MsgBox("フォント用Partファイルが見つかりません。 設定パスをチェックしてください")
        ProEnd
    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

'全フォントList
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
    Next
    GetAllFont = Join(v, vbCrLf)
End Function



'***作業Part関連***
'作業用Partファイル設定
Private Sub GetWorkPart()
    If CATIA.Documents.Count < 1 Then
        Call MsgBox("Partファイルが開かれていません")
        ProEnd
    End If
    Call WorkDoc.SetDocument(CATIA.ActiveDocument)
    If Not WorkDoc.CanUseClass Then
        Call MsgBox("アクティブなファイルがPartファイルではありません")
        ProEnd
    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
        .Clear
        Status = .SelectElement2(Filter, Msg, False)
        If Status = "Cancel" Then
            Call MsgBox("中止します")
            ProEnd
        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
        .Clear
    End With
    Set SelectItemReference = ObjRef
End Function

'SelectElement用Edgeフィルター
Private Function EdgeFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Edge"
    EdgeFilter = Ary
End Function

'SelectElement用Surfaceフィルター
Private Function SurfFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Face"
    SurfFilter = Ary
End Function

'SelectElement用端点フィルター
Private Function EndPointFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "HybridShapePointOnCurve"
    EndPointFilter = Ary
End Function

'SelectElement用押し出し方向フィルター
Private Function ThicknessDirectionFilter() As Variant
    Dim Ary(2) As Variant
    Ary(0) = "Line"
    Ary(1) = "RectilinearMonoDimFeatEdge"
    Ary(2) = "RectilinearTriDimFeatEdge"
    ThicknessDirectionFilter = Ary
End Function

'SelectElement用BrapName取得
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

'PointOnCurvePercent
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 ("指定した端点が不適切です")
            ProEnd
    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)
        Next
        With WorkDoc.Sel
            Call .Clear
            Call .Add(WorkDoc.TempHybridBody)
            For Each oAny In DeleteItem
                Call .Add(oAny)
            Next
            Call .Delete
        End With
        Call FontDoc.Doc.Close
        Set WorkDoc = Nothing
        Set FontDoc = Nothing
        Set StringData = Nothing
        Set FontData = Nothing
        FontDoc.Doc.Close
    On Error GoTo 0
    End
End Sub

先頭部分の

'フォント用Partファイルパス-この部分は各自設定してください
Const FontPartPath = "C:\temp\"
Const FontPartName = "E3DTEXT.CATPart"

は、各自の環境に合わせて書き換えてください。
(オリジナルのサイトのルールにしたがって辞書ファイルを自作し、
ここを設定すれば、独自のフォントファイルでも使えるはずです)

特に理由がなかった為、CATMainメソッドを全体の処理そのものにしました。
マクロ実行時の手順等は、ここのコメントの順番となります。
主に全体的な流れとユーザーの選択処理(SelectElement2やMsgBox)を
受け持っています。
Publicなメンバ変数が幾つもある不甲斐なさ・・・。最初は全部
Privateだったんですけどねぇw

マクロ実行時、オリジナルのものと違う部分があります。
オリジナルではボディを作成する際、文字の押し出し方向を早々と指定
することになりますが、こちらのものは文字のサーフェスが配置され
プレビューした後の指定となります。

又、オリジナルのものは文字のボディを作成する際に作った一時的な
点等を作りっぱなしにしていますが、不要なものは全て削除する
ようにしています。
マクロ実行後、CATDUAを行うと不要なものが削除されますが、これは
辞書ファイルから作業ファイルへのコピペを行った際に出るもので、
手動でも出来上がるものです。これをマクロで防ぐ手段を僕は知りません。