C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

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

CATIA_V5 VBA

こちらの続きです。
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を行うと不要なものが削除されますが、これは
辞書ﾌｧｲﾙから作業ﾌｧｲﾙへのｺﾋﾟﾍﾟを行った際に出るもので、
手動でも出来上がるものです。これをﾏｸﾛで防ぐ手段を僕は知りません。