シェイプ内のテキストの２行目だけフォントを変更

2024.11.1

vbCrLf ではなく、vbLf でうまくいった。

Sub 二行目をMeiryo_UIにできた()
Dim shape As shape
Dim textBoxText As String
Dim lines As Variant
Dim secondLineStart As Long
Dim secondLineLength As Longc

For Each shape In ActiveSheet.Shapes
    If shape.TextFrame2.HasText Then
        textBoxText = shape.TextFrame2.TextRange.Text
        lines = Split(textBoxText, vbLf)

        If UBound(lines) >= 1 Then ' 2行目が存在する場合
            secondLineStart = Len(lines(0)) + 2 ' 1行目の長さ + 改行2文字

            If Len(lines(1)) > 0 Then
                secondLineLength = Len(lines(1))
                With shape.TextFrame2.TextRange.Characters(secondLineStart, secondLineLength).Font
                    .Name = "Meiryo UI"
                    .NameFarEast = "Meiryo UI"
                    .NameComplexScript = "Meiryo UI"
                    .Size = 13
                End With
            End If
        End If
    End If
Next shape

End Sub

Sub テキストが全て表示されていないシェイプの2行目をMeiryo_8point()
Dim shape As shape
Dim textFrame As TextFrame2
Dim textRange As TextRange2
Dim textBoxText As String
Dim lines As Variant
Dim secondLineStart As Long
Dim secondLineLength As Long

For Each shape In ActiveSheet.Shapes
    If shape.TextFrame2.HasText Then
        Set textFrame = shape.TextFrame2
        Set textRange = textFrame.textRange

        ' テキストの高さをチェック
        If textRange.BoundHeight > shape.Height Then
            Debug.Print "テキストがすべて表示されていないシェイプ: " & shape.Name

            ' テキストがすべて表示されていないシェイプの2行目を更新
            textBoxText = textRange.Text
            lines = Split(textBoxText, vbLf)

            If UBound(lines) >= 1 Then ' 2行目が存在する場合
                secondLineStart = Len(lines(0)) + 2 ' 1行目の長さ + 改行2文字

                If Len(lines(1)) > 0 Then
                    secondLineLength = Len(lines(1))
                    With textRange.Characters(secondLineStart, secondLineLength).Font
                        .Name = "Meiryo UI"
                        .NameFarEast = "Meiryo UI"
                        .NameComplexScript = "Meiryo UI"
                        .Size = 8
                    End With
                End If
            End If
        End If
    End If
Next shape

End Sub

右クリックを昔風に reg.exe add “HKCU\Software\Classes\CLSID\{86ca1aa0-34aa-4e8b-a509-50c905bae2a2}\InprocServer32” /f /ve

右クリックを標準設定に戻す reg.exe delete “HKCU\Software\Classes\CLSID\{86ca1aa0-34aa-4e8b-a509-50c905bae2a2}” /f