選択セル範囲を図形のテキストボックスにするマクロその4、フォントの取り消し線、下付き上付き文字、下線

今までフォントの設定で反映していたのは文字色、フォント名、フォントサイズ、この3つだったけどその他も対応することにした

セルの書式設定のフォント設定画面

f:id:gogowaten:20191030152132p:plain

よく使うのは太字くらいかなあ、全く使わないのは下線と文字飾り、それでも全部対応することにした

テキストボックスのフォント設定

設定できる項目はセルのフォント設定とだいたい同じ

テキストボックスのほうが項目が多い

取り消し線

セルもテキストボックスも同じに見える、いいねえ

選択されたテキストボックスの文字全部に取り消し線を表示するマクロ

Sub testFont2()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
f2.Strikethrough = msoTrue
End Sub

フォントの設定なのでテキストボックスのフォント設定は

テキストボックスのTextFrame2.TextRange.Font

これに対して色々設定すればいいみたい、前々回のフォントサイズとかと一緒

上付き文字と下付き文字

これもほぼ再現できている

ただわからないのが

この相対位置

これを50%にすると

上に移動してよりセルの表示に近くなる

これをマクロで指定したいんだけど場所がわからない

選択されたテキストボックスの文字全部を上付き文字にするマクロ

Sub testFont2()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
' f2.Strikethrough = msoTrue
f2.Superscript = msoTrue '上付き文字にする
' f2.Subscript = msoTrue '下付き文字にする
End Sub

Font2のSuperscriptにmsoTrueを指定するだけで上付き文字になるのはいいけど

表示位置を指定する相対位置ってのがどこにあるのかわからないし、ググっても見つからない

こんなときマクロの記録ができれば1回でわかるんだよなあ

太字、斜体

選択されたテキストボックスの文字全部を太字、斜体にするマクロ

Sub testFont2()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
' f2.Strikethrough = msoTrue
' f2.Superscript = msoTrue '上付き文字にする
' f2.Subscript = msoTrue '下付き文字にする
f2.Bold = msoTrue '太字
f2.Italic = msoTrue '斜体
End Sub

取り消し線とかと同じ

セルの下線、Underline

4種類ある

それぞれどんな表示になるのか

下線(会計)ってのは文字の下だけじゃなくて

セルの幅いっぱいに下線が引かれるみたい

これは再現できそうにない

テキストボックスの下線の種類

やっぱり文字列がないところまで線を伸ばすのはなさそうね

結果

二重下線は一本の太い線に見えるけど

フォントサイズを大きくすると二重になっているのがわかる、微妙…

Font2のUnderlineStyleに下線の種類を指定する

なんかいっぱい候補が出てくるけど使うのは

一重線のmsoUnderlineSingleLine

二重線のmsoUnderlineDoubleLine

のどちらかだけ

選択されたテキストボックスの文字全部に下線を表示するマクロ

Sub testFont2()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
Dim f2 As Font2
Set f2 = s.TextFrame2.TextRange.Font
f2.UnderlineStyle = msoUnderlineSingleLine '下線
' f2.UnderlineStyle = msoUnderlineDoubleLine '二重線の下線
End Sub

セルのフォントの設定はセルごとに指定できるのはもちろん、1文字ごとにも指定できる

1文字ごとに調べてテキストボックスの方の文字も設定すれば1番確実だけど、処理時間がかかりすぎる！試しに実行したところ100文字で5秒以上かかったｗ

セルの中で複数の設定があるかどうかは判定できるので、同じだった場合はセル単位で設定して、違っていた場合だけ1文字ごとに設定するようにした

判定方法

例えば1セルの中すべてが太字だった場合は

セルのFont.Boldの値はTrueだけど

1セルに太字指定の文字と指定なしの文字がある場合は

セルのFont.Boldの値はNullになっている

なのでNullなら混在って判定ができる

これは下線とかでも同じで混在していたらNullになっている

sTextがテキストボックスの文字列、rがセル

'フォント太字
Sub SetFontBoldSub(sText As TextRange2, r As Range)
If IsNull(r.Font.Bold) Then
For i = 1 To sText.Characters.Count
sText.Characters(i, 1).Font.Bold = _
r.Characters(i, 1).Font.Bold
Next
Else
sText.Font.Bold = r.Font.Bold
End If
End Sub

すべて太字か標準なら

sText.Font.Bold = r.Font.Bold

太字と標準が混じっていたら1文字ごとなのでCharactersを使って

For i = 1 To sText.Characters.Count

sText.Characters(i, 1).Font.Bold = _

r.Characters(i, 1).Font.Bold

下線の場合はTrue、Falseの指定じゃないので少し違う

'フォント下線
Sub SetFontUnderLineSub(sText As TextRange2, r As Range)
Dim rf As Font
Dim sf As Font2
If IsNull(r.Font.Underline) Then
For i = 1 To sText.Characters.Count
Set rf = r.Characters(i, 1).Font
Set sf = sText.Characters(i, 1).Font
Select Case rf.Underline
Case xlUnderlineStyleSingle, xlUnderlineStyleSingleAccounting
sf.UnderlineStyle = msoUnderlineSingleLine
Case xlUnderlineStyleDouble, xlUnderlineStyleDoubleAccounting
sf.UnderlineStyle = msoUnderlineDoubleLine
End Select
Next
Else
Set rf = r.Font
Set sf = sText.Font
Select Case rf.Underline
Case xlUnderlineStyleSingle, xlUnderlineStyleSingleAccounting
sf.UnderlineStyle = msoUnderlineSingleLine
Case xlUnderlineStyleDouble, xlUnderlineStyleDoubleAccounting
sf.UnderlineStyle = msoUnderlineDoubleLine
End Select
End If
End Sub