VBAでテキストボックスのフォント指定は難しかった

選択セルの値を使ってテキストボックスを作成するマクロを書いていて

フォントの指定が難しかったのでメモ

テキストボックスを作りたいセルを選択してマクロを実行

セルの値が入ったテキストボックスが作成された

これが求めていた結果、ここまで難しかった

期待はずれな例

日本語の文字だけが指定したフォントにならずに

MS ゴシックになっていた

正解のフォントの指定の仕方は

charaCount=Shape.TextFrame2.TextRange.Characters.Count'文字数カウント

Shape.TextFrame2.TextRange.Characters(1, charaCount).Font.Name = フォント名 '英数字用

Shape.TextFrame2.TextRange.Characters(1, charaCount).Font.NameFarEast = フォント名 '日本語用

TextFrame2のTextRangeのCharactersで文字列のどこからどこまでかを指定していして

ここでは全部の文字だから1番目の文字から文字数(最後の文字)を指定して

ここでやっとフォントの指定のFont.Nameでフォントを指定する

しかも

Font.Nameっていう半角英数字用と

Font.NameFarEastっていう日本語用

この2つに指定しなければならない

2016/09/10追記ここから

    With Shape.TextFrame2.TextRange.Font
        .Name = Font.Name '英数字用？フォント指定        .NameFarEast = Font.Name '日本語用フォント指定        .Size = Font.Size
    End With

文字数をカウントする必要なかったｗ

TextFrame2のTextRangeのFontのNameとNameFarEastそれぞれに

フォント名を指定するのは変わらない

2016/09/10追記ここまで

Excel 2007 のテキストボックスで使用するフォントの種類をマクロで変更できない

https://support.microsoft.com/en-us/kb/945500/ja?wa=wsignin1.0

マイクロソフトのここを見ると現在調査中ってあるけど

2007年11月から何年調査しているんだろうって、エクセル2007のバグか仕様みたい

回避策としてFont.NameFarEastっていう日本語用だけを指定すればいいように書いてあるけど、フォントによっては両方共指定しないとおかしくなる

紛らわしかったのがテキストボックスや図形のフォントの指定ができそうなところがあちこちにあること

Shape.TextEffect.FontName

Shape.TextFrame.Characters.Font.Name

Shape.TextFrame.Characters(1,n).Font.Name

Shape.TextFrame2.Characters.Font.Name

Shape.TextFrame2.Characters(1,n).Font.Name

TextBox.Font.Name

これ全部できそうに見えてできないもので

正解は

Shape.TextFrame2.Characters(1,n).Font.Name

Shape.TextFrame2.Characters(1,n).Font.NameFarEast

この2つ、両方必要

あとエクセル2007は図形関係のマクロの記録ができない！

なので手動で変更してどんな動きしているのか見ることもできず

そんなこんなで時間がかかった

セルのフォント指定は

Range.Font.Name

でできるんだからテキストボックスとかの図形も

Shape.Font.Name

これでできればわかりやすいのになあ

せめてShape.TextFrame.Font.Nameとか

選択セルの値でテキストボックスを作成するマクロ

Sub SelectionValueTextBox選択セルの値でテキストボックスを作成する()

On Error Resume Next

Dim r As Range

Dim s As Shape

Dim sh As Worksheet: Set sh = ActiveSheet

Dim charaCount As Long

For Each r In Selection

'テキストボックス作成

Set s = sh.Shapes.AddTextbox( _

msoTextOrientationHorizontal, r.Width + r.Left, r.Top, r.Width, r.Height)

s.TextEffect.Text = r.Value 'セルの値をテキストボックスの文字に指定

With s.TextFrame

.HorizontalAlignment = xlHAlignCenter '水平中央

.VerticalAlignment = xlVAlignCenter '垂直中央

.AutoSize = True 'テキストに合わせてサイズを自動変更

End With

charaCount = s.TextFrame2.TextRange.Characters.Count '文字数カウント

With s.TextFrame2.TextRange.Characters(1, charaCount).Font 'フォント設定

.Name = r.Font.Name '英数字

.NameFarEast = r.Font.Name '日本語

.Size = r.Font.Size 'サイズ

End With

'背景色ランダム、文字色白

' Randomize

' s.Fill.ForeColor.RGB = Int((16777215 - 0 + 1) * Rnd(16777215) - 0)

' s.TextFrame.Characters.Font.Color = RGB(255, 255, 255)

End Sub

2016/09/10追記ここから

'アクティブセルの値を使ってテキストボックス作成
Sub AddTextBoxFromCellValue()
    'セル以外が選択されていたらなにもしないで終了
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim r As Range
    Set r = ActiveCell
    Dim tb As Shape
    Set tb = ActiveSheet.Shapes.AddTextbox( _
                msoTextOrientationHorizontal, _
                r.Left + r.Width, r.Top, r.Width, r.Height)
                
    'テキストボックスのフォントとフォントサイズは
    'セルと同じものを指定
    With tb.TextFrame2.TextRange
        .text = r.Value
        With .Font
            .Name = r.Font.Name '英数字用？フォント指定
            .NameFarEast = r.Font.Name '日本語
            .Size = r.Font.Size 'サイズ
        End With
    End With
    
    'テキストボックスのサイズを文字に合わせる
    tb.TextFrame.AutoSize = True
End Sub

この状態で実行すると

こうなる

フォントがＭＳゴシックにならずに

セルと同じMeiryo UIになっている

'複数選択セルの値のテキストボックスをそれぞれ作成
Sub AddTextBoxesFromCellsValue()
    'セル以外が選択されていたらなにもしないで終了
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim r As Range
    For Each r In Selection
        Dim tb As Shape
        Set tb = ActiveSheet.Shapes.AddTextbox( _
                    msoTextOrientationHorizontal, _
                    r.Left + r.Width, r.Top, r.Width, r.Height)
                    
        'テキストボックスのフォントとフォントサイズは
        'セルと同じものを指定
        With tb.TextFrame2.TextRange
            .text = r.Value
            With .Font
                .Name = r.Font.Name '英数字用？フォント指定
                .NameFarEast = r.Font.Name '日本語
                .Size = r.Font.Size 'サイズ
            End With
        End With
        
        'テキストボックスのサイズを文字に合わせる
        tb.TextFrame.AutoSize = True
        
'        背景色ランダム､文字色白
        Randomize
        tb.Fill.ForeColor.Rgb = Int((16777215 - 0 + 1) * Rnd(16777215) - 0)
        tb.TextFrame.Characters.Font.Color = Rgb(255, 255, 255)
    Next
End Sub