読者です 読者をやめる 読者になる 読者になる

C#ATIA

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

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

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

続いてクラスモジュールとしては最後のText3DStringContainerクラスです。
このクラスは文字モデルそのものを保持しています。

'text3D VBA
'Text3DStringContainer
Option Explicit

Private mChars As Collection 'Text3DCharClassコレクション
Private mText As String
Private mCanUseClass As Boolean
Private mParams As Parameters
Private mText_Spaces As Double '文字-文字幅
Private mText_Hight As Double
Private mSpace_Width As Double 'スペース・辞書未登録文字幅
Private mThicknessType As ThicknessDirectionType '押し出し方向タイプ
Private mNormalLine As Text3DObjRefClass
Private mAllWidth As Double 'スペース込みの全文字幅
Private mTextScale As Double
Private mBaseAxisSystem As Text3DObjRefClass
Private mTxtBody As Body '文字のボディ

Private Sub Class_Initialize()
    mCanUseClass = True
End Sub

'***FontDoc関連***
'各種の設定
Sub SetParameters(Params As Parameters)
    Set mParams = Params
    If Not TryGetParamValue("text spaces", mText_Spaces) Then mCanUseClass = False
    If Not TryGetParamValue("text hight", mText_Hight) Then mCanUseClass = False
    If Not TryGetParamValue("space width", mSpace_Width) Then mCanUseClass = False
End Sub

Property Get CanUseClass() As Double
    CanUseClass = mCanUseClass
End Property

Property Get Text_Spaces() As Double
    Text_Spaces = mText_Spaces
End Property

Property Get Text_Hight() As Double
    Text_Hight = mText_Hight
End Property

Property Get Space_Width() As Double
    Space_Width = mSpace_Width
End Property

'パラメータの取得
Private Function TryGetParamValue(Key As String, Out_Value As Double) As Boolean
    Dim Para As Parameter
    For Each Para In mParams
        If InStr(1, Para.Name, Key) > 0 Then
            Out_Value = Para.Value
            TryGetParamValue = True
            Exit Function
        End If
    Next
    TryGetParamValue = False
End Function


'***WorkDoc関連***
Property Let ThicknessType(Ty As ThicknessDirectionType)
    mThicknessType = Ty
End Property

Property Get ThicknessType() As ThicknessDirectionType
    ThicknessType = mThicknessType
End Property

Property Let NormalLine(N As Text3DObjRefClass)
    Set mNormalLine = N
End Property

Property Get NormalLine() As Text3DObjRefClass
    Set NormalLine = mNormalLine
End Property

Property Get TextScale() As Double
    TextScale = mTextScale
End Property

Sub SetCurveLength(CurveLength As Double)
    mTextScale = CurveLength / mAllWidth
End Sub

Property Get Chars() As Collection
    Set Chars = mChars
End Property

Property Get BaseAxisSystem() As Text3DObjRefClass
    Set BaseAxisSystem = mBaseAxisSystem
End Property

Property Let BaseAxisSystem(A As Text3DObjRefClass)
    Set mBaseAxisSystem = A
End Property

Property Get TxtBody() As Body
    Set TxtBody = mTxtBody
End Property


'大文字限定
Sub SetString(S As String)
    If Len(S) < 1 Then
        MsgBox ("中止します")
        ProEnd
    End If
    mText = S
    Dim Ary As Variant
    Ary = ToArray(UCase(S))
    Set mChars = New Collection
    
    Dim i As Long
    mAllWidth = 0
    For i = 0 To UBound(Ary)
        Dim Char As New Text3DCharClass
        Char.Char = Ary(i)
        Char.Width = Space_Width '暫定的な幅を代入
        Char.Distance = mAllWidth + Text_Spaces * i
        '押し出し方向入れる
        mAllWidth = mAllWidth + Char.Width
        Call mChars.Add(Char)
        Set Char = Nothing
    Next
    mAllWidth = mAllWidth + Text_Spaces * (UBound(Ary) - 1)
End Sub

Private Function ToArray(ByVal str As String) As Variant
    Dim length_ As Integer, i As Integer
    Dim rtn_ary() As String

    If str = "" Then
        ReDim rtn_ary(0)
        rtn_ary(0) = ""
    Else
        length_ = Len(str)
        ReDim rtn_ary(length_ - 1)
        For i = 1 To length_
            rtn_ary(i - 1) = Mid(str, i, 1)
        Next i
    End If
    ToArray = rtn_ary
End Function

'全Charの配置
Sub CreateFontSurface()
    Dim C As Text3DCharClass
    Dim Origin As Text3DObjRefClass
    Dim Tangency As Text3DObjRefClass
    Dim Normal As Text3DObjRefClass
    
    BaseAxisSystem = CreateBaseAxisSystem
    Call ElementHide(BaseAxisSystem)
    For Each C In mChars
        '基準点
        Set Origin = CreatePointOnCurveFromDistance( _
            GuideData.GuideCurve.BrapRef, _
            C.Distance * TextScale, GuideData.IsReverse)
        Call ElementHide(Origin)
        
        '接線
        Set Tangency = CreateLineTangency( _
            GuideData.GuideCurve.BrapRef, _
            Origin.ObjRef)
        Call ElementHide(Tangency)
        
        '法線
        Set Normal = CreateLineNormal( _
            GuideData.SupportFace.BrapRef, _
            Origin.ObjRef)
        Call ElementHide(Normal)
        
        '座標系
        C.Axis = CreateAxisSystem(Origin.ObjRef, Tangency.ObjRef, Normal.ObjRef)
        Call ElementHide(C.Axis)
        
        If C.CanUseClass Then
            'フォントコピペ
            C.BaseFont = FontCopyPaste(C)
            Call ElementHide(C.BaseFont)
            
            '配置
            C.ResultFont = CreateScaling(CreateAxisToAxis(C.BaseFont.ObjRef, C.Axis.ObjRef).ObjRef, Origin.ObjRef)
            Call WorkDoc.TempHybridBody.AppendHybridShape(C.ResultFont.Obj)
        End If
    Next
End Sub

'AxisToAxis
Private Function CreateAxisToAxis(SurfRef As Reference, _
                                  ToAxisRef As Reference) As Text3DObjRefClass
    Set CreateAxisToAxis = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewAxisToAxis(SurfRef, BaseAxisSystem.ObjRef, ToAxisRef), True)
End Function

'Scaling
Private Function CreateScaling(SurfRef As Reference, _
                               OriginRef As Reference) As Text3DObjRefClass
    Set CreateScaling = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewHybridScaling(SurfRef, OriginRef, TextScale), True)
End Function

'PointOnCurveDistance
Private Function CreatePointOnCurveFromDistance( _
                    CurveRef As Reference, _
                    Distance As Long, _
                    Reverse As Boolean) As Text3DObjRefClass
    Set CreatePointOnCurveFromDistance = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewPointOnCurveFromDistance(CurveRef, Distance, Reverse), True)
End Function

'LineTangency
Private Function CreateLineTangency( _
                    CurveRef As Reference, _
                    PointRef As Reference) As Text3DObjRefClass
    Set CreateLineTangency = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewLineTangency(CurveRef, PointRef, 0#, 1#, False), True)
End Function

'LineNormal
Private Function CreateLineNormal( _
                    FaceRef As Reference, _
                    PointRef As Reference) As Text3DObjRefClass
    Set CreateLineNormal = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewLineNormal(FaceRef, PointRef, 0#, 1#, False), True)
End Function

'Update
Private Function UpdateRegisterElement(Obj As AnyObject, _
                                       DelFG As Boolean) As Text3DObjRefClass
    Call WorkDoc.Part.UpdateObject(Obj)
    Dim PntObj As New Text3DObjRefClass
    PntObj.Obj = Obj
    Set UpdateRegisterElement = PntObj
    '削除予約
    If DelFG Then
        Call DeleteObj.Add(Obj)
    End If
End Function

'Axis
Private Function CreateAxisSystem( _
                    Ori As Reference, _
                    X As Reference, _
                    Z As Reference) As Text3DObjRefClass
    Dim Axis As AxisSystem
    Set Axis = WorkDoc.AxisSystems.Add
    With Axis
        .OriginType = catAxisSystemOriginByPoint
        .OriginPoint = Ori
        .XAxisType = IIf(GuideData.IsReverse, catAxisSystemAxisOppositeDirection, catAxisSystemAxisSameDirection)
        .XAxisDirection = X
        .YAxisType = 0
        .ZAxisType = catAxisSystemAxisOppositeDirection
        .ZAxisDirection = Z
        .IsCurrent = False
    End With
    Set CreateAxisSystem = UpdateRegisterElement(Axis, True)
    '削除予約
    Call DeleteItem.Add(Axis)
End Function

'BaseAxis
Private Function CreateBaseAxisSystem() As Text3DObjRefClass
    Dim Axis As AxisSystem
    Set Axis = WorkDoc.AxisSystems.Add
    Set CreateBaseAxisSystem = UpdateRegisterElement(Axis, True)
    '削除予約
    Call DeleteItem.Add(Axis)
End Function

'invert
Sub AxisReverse(AxisXZ As String)
    Dim C As Text3DCharClass
    For Each C In mChars
        If C.CanUseClass Then
            Select Case AxisXZ
                Case "X"
                    Call AxisReverseX(C.Axis.Obj)
                Case "Z"
                    Call AxisReverseZ(C.Axis.Obj)
            End Select
            Call WorkDoc.Part.UpdateObject(C.Axis.Obj)
            Call WorkDoc.Part.UpdateObject(C.ResultFont.Obj)
        End If
    Next
End Sub

Private Sub AxisReverseX(Ax As AxisSystem)
    With Ax
        .XAxisType = IIf(.XAxisType = catAxisSystemAxisSameDirection, _
            catAxisSystemAxisOppositeDirection, catAxisSystemAxisSameDirection)
        .YAxisType = 0
    End With
End Sub

Private Sub AxisReverseZ(Ax As AxisSystem)
    With Ax
        .ZAxisType = IIf(.ZAxisType = catAxisSystemAxisSameDirection, _
            catAxisSystemAxisOppositeDirection, catAxisSystemAxisSameDirection)
        .YAxisType = 0
    End With
End Sub

'Boundar
Sub CreateBoundary()
    Dim C As Text3DCharClass
    
    For Each C In mChars
        If C.CanUseClass Then
            C.Boundary = CreateCurveDatum(CreateBoundaryOfSurface(C.ResultFont.ObjRef).ObjRef)
            Call WorkDoc.WorkHybridBody.AppendHybridShape(C.Boundary.Obj)
        End If
    Next
End Sub

'BoundaryOfSurface
Private Function CreateBoundaryOfSurface(SurfRef As Reference) As Text3DObjRefClass
    Set CreateBoundaryOfSurface = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewBoundaryOfSurface(SurfRef), True)
End Function

'CurveDatum
Private Function CreateCurveDatum(CurveRef As Reference) As Text3DObjRefClass
    Set CreateCurveDatum = UpdateRegisterElement( _
        WorkDoc.HSFac.AddNewCurveDatum(CurveRef), False)
End Function

'文字用Body作成
Private Sub CreateBody()
    Set mTxtBody = WorkDoc.Part.Bodies.Add()
    TxtBody.Name = "Text3D_" + mText
End Sub

'3DTextBody作成
Sub CreateTxtBody()
    'Bodyの作成
    Call CreateBody
    WorkDoc.Part.InWorkObject = TxtBody
    
    'Pad
    Dim C As Text3DCharClass
    For Each C In mChars
        If C.CanUseClass Then
            Call CreatePad(C.Boundary.ObjRef)
        End If
    Next
    
    'Body更新
    On Error Resume Next '失敗の可能性あり
        Call WorkDoc.Part.UpdateObject(TxtBody)
    On Error GoTo 0
End Sub

'Pad
Sub CreatePad(CurveRef As Reference)
    Dim CharPad As Pad
    Set CharPad = WorkDoc.ShapeFactory.AddNewPadFromRef(CurveRef, Text_Hight)
    If ThicknessType = tLine Then
        Call CharPad.SetDirection(NormalLine.SelRef)
    End If
End Sub

想像以上に肥大化してしまい、分割したかったのですがなかなか時間が
取れない為このまま公開です。

細かな役割としては、
・辞書ファイルから取得したパラメータを保持(SetParametersメソッド)。
・入力された文字列の保持(SetStringメソッド)。
・プレビュー用に配置されたサーフェスの作成(CreateFontSurfaceメソッド)。
・文字のボディの作成(CreateTxtBodyメソッド)。
肥大化した最大の理由は、CATIAのコマンド類のメソッドをこのクラスに取り込んで
しまった事です。"コンテナ" と言うネーミングがふさわしくないクラスになってしまいました。
C#化する際は外に出そう・・・。