setwithFonts

　graphics ML え～さんノビのさんのアイデアで、文字コードを判定して欧文、ひらがな、それ以外でフォントやサイズ、垂直位置を調整した文字組を実現するコードを書きました
　フォントの設定が思ったようにいかず、テキストを全部削除して1文字ずつすべての属性を設定しながら追加するという恐ろしく効率の悪い処理方法を採用しました。
　このテキスト周りの処理、ちょっとややこしすぎです。もっと素直な作りかわかりやすい説明をお願いします。＞Corelさん

---

Attribute VB_Name = "setwithFonts"
Option Explicit

Sub Main()
' ResetLocale
' Copyright by Albatross (c)2003
' Ver 1.00 2003/10/30
' Ver 1.01 2003/11/01

    Dim ccode As Integer
    Dim wcounter As Integer
    Dim countmax As Integer
    Dim objtext As Text
    Dim wt As TextRange
    Dim stringbuffer As String
    Dim currstring As String
    
    If ActiveDocument Is Nothing Then
        MsgBox "ドキュメントがありません", vbCritical, "Error"
        Exit Sub
    End If
    If Application.ActiveSelection.Shapes.Count <> 1 Then
        MsgBox "オブジェクトが選択されていないか、複数選択されています", vbCritical, "Error"
        Exit Sub
    End If
    If Application.ActiveSelection.Shapes(1).Type <> cdrTextShape Then
        MsgBox "選択されたオブジェクトはテキストではありません", vbCritical, "Error"
        Exit Sub
    End If
    
    Set objtext = Application.ActiveSelection.Shapes(1).Text
    With objtext.Story
        stringbuffer = .WideText
        .Characters.All.Delete
    End With
    countmax = Len(stringbuffer)
    For wcounter = 1 To countmax
        currstring = Mid$(stringbuffer, wcounter, 1)
        
        ccode = AscW(currstring)
        With objtext.Story.Characters.Last
            If ccode > -1 And ccode < 256 Then '半角
                Set wt = .InsertAfter(currstring, cdrEnglishUS, cdrCharSetANSI, "Arial Black")
                With wt
                    .Size = 14
                    .VertShift = 0
                End With
            ElseIf ccode < -31849 Then 'たぶんひらがな・カタカナと一部記号
                Set wt = .InsertAfterWide(currstring, cdrJapanese, cdrCharSetShiftJIS, "ＭＳ ゴシック")
                With wt
                    .Size = 12
                    .VertShift = 6
                End With
            Else
                Set wt = .InsertAfterWide(currstring, cdrJapanese, cdrCharSetShiftJIS, "ＭＳ 明朝")
                With wt
                    .Size = 16
                    .VertShift = 0
                End With
            End If
        End With
    Next wcounter
End Sub

---

＜＜戻る