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

続いてｸﾗｽﾓｼﾞｭｰﾙとしては最後の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#化する際は外に出そう・・・。
C#ATIA

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

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