選択セル範囲を図形のテキストボックスにするマクロその2、タブ位置調整

前回

gogowaten.hatenablog.com

図形のテキストボックスのタブ文字、タブ位置とかのメモ、選択セル範囲を1つのテキストボックスにするマクロ ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14686706.html

の続き

目的

選択セル範囲をテキストボックスにするときに

見た目を同じにする

テキストボックスの文字の中央揃え

中央揃えにしたいところを選択するとツールバーみたいなのが出てくる

その中に中央揃えにするボタンがあるのでクリックで中央揃えになる

けど、この方法では行ごとにしか指定できないので

こんなふうに3.6っていう数値だけ、とかはできなくて

同じ行にあるbottomっていう文字も一緒に移動してしまう

これを解決するのがこの前の記事でもあった

タブの設定、タブ位置の設定

タブの設定画面を出す

前回の記事からの流用

今回は複数行あるから全部の行を選択して

右クリックメニューから段落

1cmのところにタブを追加する

中央揃えにするから配置は中央を選択してから

設定してOKボタン

これで中央揃えになるのかなあと思ったら

変化なし

左から1cmのところに追加したタブがあるはずなので

2行目の先頭にカーソルを置いてtabキーを押してあげると

中央揃えになった！

他の行も頭にタブを入れると中央揃えになる

3行目の7.2を右揃えにしてみる

3行目のタブ設定画面でさっきの1cmのタブ位置をクリアボタンで消して

おなじ1cmにして、配置を右にして設定ボタンで追加

OK押してみてみると

3行目だけ右揃えになった

こんな感じになっているんだろうねえ

ってことはマクロで処理するときは

文字列の頭にタブ文字(vbTab)を追加してあげればいいことになる

例えば

左の選択セル範囲から作った右のテキストボックスの中のテキストは

vbTab & Margin & vbTab & DefaultValue & vbNewLine & vbTab & Bottom & vbTab & 3.6

になっている、vbNewLineは改行文字

タブ位置を追加しないときのタブ位置は

この既定値の2.54cmが使われて

配置は左揃えになっているので

これらを変更してあげればいいみたい

既定値は0にする

そうしないとタブ位置を1cmと3cmに追加した場合でも

1cmの次のタブは3cmではなく

既定値の2.54cmになってしまうから

追加するタブ位置の決定はセル幅を基準にする

テキストボックスの1行目にタブ位置50，配置左を追加するときは

テキストボックス.TextFrame2.TextRange.Paragraphs.Item(1).ParagraphFormat.TabStops.Add msoTabStopLeft, 50

自身のセルの前のセル幅をTabStops.Positionに使うとピッタリな感じ

全部左揃えならこれで問題ない

3列め以降はこの数値にどんどん足していく

2列目の幅が66なら64+66＝130が3列目のタブ位置になる

二列目の数値のところは中央揃えにしたいからもっと右にしたい

これは自身(3.6)があるセル幅の半分を足せば良さそうってことで

自身のセル幅66の半分33を64に足して97！

中央揃えにしたいから

TabStops.TypeはmsoTabStopCenter

追加だから

TabStops.Add msoTabStopcenter, 97

右揃え

自身のセル幅付近に追加してTabStops.TypeはmsoTabStopRight

64ピッタリじゃなくて64付近なのか

もしDefaultValueの数値(3.6)があるセルが左揃えだった場合

左揃えのときは自身のセルの前のセル幅を使うのでタブ位置64

bottomがあるセルは右揃えなのでタブ位置は自身のセル幅64

別の文字列が同じタブ位置を使うことはできないので不都合が起こるから

なので右揃えのときは前のセル幅にプラスかマイナスした数値を使うってことで付近

タブ位置の決定

左揃え

前のセル幅を使い列ごとにどんどん足していく、これを基準値にする

中央揃え

基準値に自身のセル幅の半分を足す

右揃え

基準値に自身のセル幅を足した値付近

選択セル範囲をテキストボックスにするマクロその2

testTableTextBox2を実行するとテキストボックスができる

'中央揃え、右揃えに対応版
'セル範囲をテキストボックス
Sub testTableTextBox2()
      '選択されているのがセル以外なら何もしないで終了
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim myCells As Range:    Set myCells = Selection
    Dim tlCell As Range:    Set tlCell = myCells.Cells(1) '左上のセル
    
    'テキストボックス作成
    Dim myTB As Shape
    Set myTB = ActiveSheet.Shapes.AddTextbox( _
                msoTextOrientationHorizontal, _
                tlCell.Left, tlCell.Top, 100, 10)
    myTB.TextFrame.AutoSize = True 'オートサイズを有効にする
    myTB.Placement = xlMove 'セルに合わせて移動するけどサイズ変更しない
'    myTB.Placement = xlFreeFloating '移動もサイズ変更もしない
    
    'テキストボックスに表示する文字列を作成
    Dim str As String
    Dim rRow As Range
    str = testGetString2(myCells)
    'テキストボックスにテキスト指定
    myTB.TextFrame2.TextRange.text = str
    
    'フォントカラーとフォントの設定
    Call SetFontColorAndFont(myTB, myCells)
    'セル幅に合わせたタブ位置を設定する
    Call AddTabPosition(myTB, myCells)
    
End Sub





'渡されたセル範囲の値(text)を表形式用に繋げて返す
'1行の値はタブ文字で繋げて、行が変わったら改行文字でつなげる
Function testGetString2(r As Range) As String
    Dim str As String
    Dim rr As Range
    Set rr = r.Cells.Rows(1)
    '先頭にタブ文字を入れているのは
    '文字の水平位置が左寄せの他にも対応するためで
    'これがないと最初の文字列が必ず0から始まってしまい
    'もし最初のセルが左寄せ以外のときでも0になってしまうから
    str = vbTab & GenerateString(rr, True)
    
    '2行以上あるとき
    If r.Rows.Count > 1 Then
        Dim i As Long
        For i = 2 To r.Rows.Count
            Set rr = r.Cells.Rows(i)
            str = str & vbNewLine & vbTab & GenerateString(rr, True)
        Next
    End If
    testGetString2 = str
    
End Function


'文字列生成、
'渡されたセル範囲にある文字列を繋げて返す
'渡すセル範囲は1行か1列のどちらか
'horiはHorizontalで
'Trueならタブ文字でつなげる
'Falseなら改行文字でつなげる
Function GenerateString(r As Range, Optional hori As Boolean = False) As String
    Dim str As String
    str = r.Cells(1).text
    If r.Cells.Count = 1 Then
        GenerateString = str
        Exit Function
    End If
    '2セル以上のとき
    Dim i As Long
    If hori Then
        'タブ文字でつなげる
        For i = 2 To r.Cells.Count
            str = str & vbTab & r.Cells(i).text
        Next
    Else
        '改行文字でつなげる
        For i = 2 To r.Cells.Count
            str = str & vbNewLine & r.Cells(i).text
        Next
    End If
    GenerateString = str
End Function


'テキストボックスのフォントカラーとフォントをセルと同じにする
'sはテキストボックス(図形)、tableRにはセル範囲を渡す
Sub SetFontColorAndFont(s As Shape, tableR As Range)
    Dim i As Long, j As Long, k As Long
    Dim r As Range, rowR As Range
    Dim p As TextRange2
    
    'Paragraph(1行)ごとに処理
    'Paragraphの文字列はtab, text, tab, text...って並んでいる
    For k = 1 To tableR.Rows.Count
        Set p = s.TextFrame2.TextRange.Paragraphs(k)
        Set rowR = tableR.Cells.Rows(k) '1行
        Dim cStart As Long '処理する文字のスタート位置
        '最初の文字はタブ文字で色は関係ないのでスタート位置は1
        cStart = 1
        '1セルごとに処理
        Dim char As TextRange2 ' Characters
        For i = 1 To rowR.Cells.Count
            Set r = rowR.Cells(i) '1セル
            '対象となる1セルに対応した文字列
            Set char = p.Characters(cStart + 1, Len(r.text))
            'セルのフォントカラーがNullなら複数の色が指定されているので
            '1文字ごとに色指定する
            If IsNull(r.Font.Color) Then
                For j = 1 To char.Length
                    char.Characters(j, 1).Font.Fill.ForeColor.Rgb _
                    = r.Characters(j, 1).Font.Color'1文字色指定
                Next
            Else
                '1セルごとに色指定
                char.Font.Fill.ForeColor.Rgb = r.Font.Color
            End If
            
            '1セルごとにフォント設定
            With char.Font
                .Name = r.Font.Name
                .NameFarEast = r.Font.Name
                .Size = r.Font.Size
            End With
            '次に処理する文字のスタート位置
            cStart = cStart + Len(r.text) + 1
        Next
    Next k
End Sub




'図形の中のテキストにタブ位置を追加
'セル範囲と図形を渡す
'セル幅を使うのでテキストとセルの値が対応している必要がある
Sub AddTabPosition(tb As Shape, r As Range)
    Call ClearTabStops(tb) 'タブ位置をすべて消去
    Dim ps As TextRange2
    Set ps = tb.TextFrame2.TextRange.Paragraphs
    Dim i As Long
    '1行ごとにタブ位置を追加
    For i = 1 To ps.Count
        'タブの既定値は邪魔なので0にする
        ps.Item(i).ParagraphFormat.TabStops.DefaultSpacing = 0
        '1行ごとタブ位置追加
        'Call AddTabPositionSub(ps.Item(i), r.Cells.Rows(i))
        '中央揃え対応版
        Call AddTabPositionSub2(ps.Item(i), r.Cells.Rows(i))
    Next
End Sub


'タブ位置すべてをクリア
'渡された図形の中のテキストのタブ位置を消去
Sub ClearTabStops(s As Shape)
    '図形にテキストがなければ何もしないで終了
    If s.TextFrame2.HasText = msoFalse Then Exit Sub
    Dim ps As TextRange2
    Set ps = s.TextFrame2.TextRange.Paragraphs
    Dim tss As TabStops2
    Dim i As Long
    Dim ts As TabStop2
    For i = 1 To ps.Count
        Set tss = ps.Item(i).ParagraphFormat.TabStops
        For Each ts In tss
            ts.Clear
        Next
    Next
End Sub


'タブ位置を追加、位置はセル幅を元に設定する
'左揃え、中央揃え、右揃えに対応
'pfはParagraph、rは1行のセル範囲
'AddTabPositionと一緒に使う
Sub AddTabPositionSub2(pf As TextRange2, r As Range)
    Dim po As Single 'タブ位置Position
    Dim tss As TabStops2
    Set tss = pf.ParagraphFormat.TabStops
    Dim nowR As Range: Set nowR = r.Cells(1)
    '先頭のタブ位置を追加
    Call SetTabStop(nowR, tss, 0)
    po = tss.Item(1).Position
        
    'セルが1個だけのときはここで終了
    If r.Cells.Count = 1 Then Exit Sub

    'セルが2個以上のとき
    '2番目以降のタブ位置を追加
    Dim beforeR As Range
    Dim i As Long
    For i = 2 To r.Cells.Count
        Set beforeR = r.Cells(i - 1)
        Set nowR = r.Cells(i)
        
        '1つ前のタブ位置に1つ前のセル幅を足す
        'これが次のタブ位置の基準になる
        po = po + beforeR.Width
        
        'タブ位置の調整
        If beforeR.HorizontalAlignment = xlCenter Then
            '1つ前のセルが中央揃えのとき、1つ前のセル幅の半分をひく
            po = po - (beforeR.Width / 2)
        ElseIf beforeR.HorizontalAlignment = xlRight _
            Or (IsNumeric(beforeR.Value2) _
                And beforeR.HorizontalAlignment = xlGeneral) Then
            '１つ前のセルが右揃えのとき、１つ前のセル幅分をひく、4は調整
            po = po - beforeR.Width + 4
        End If
        
        'タブ位置を追加する
        Call SetTabStop(nowR, tss, po)
    Next
End Sub


'タブ位置を調整してから追加
'セルのHorizontalAlignmentとセル幅に依って調整
Sub SetTabStop(r As Range, tss As TabStops2, po As Single)
    'タブ位置を追加する
    If r.HorizontalAlignment = xlCenter Then
        'セルが中央揃えのとき、セル幅の半分を足す
        po = po + (r.Width / 2)
        tss.Add msoTabStopCenter, po
    ElseIf r.HorizontalAlignment = xlRight _
        Or (IsNumeric(r.Value2) _
            And r.HorizontalAlignment = xlGeneral) Then
        '右揃えか数値(指定なしだと数値は通常右揃え)のときだけは
        '調整で-4、こうしておくと右揃えの次に左揃えが来たときに
        'タブ位置が重なること防ぐことになるし、見た目も良くなる
        po = po + r.Width - 4
        tss.Add msoTabStopRight, po
    Else
        '左揃えか指定なしの文字列のとき
        tss.Add msoTabStopLeft, po
    End If
End Sub

'中央揃え、右揃えに対応版
'セル範囲をテキストボックス
Sub testTableTextBox2()
'選択されているのがセル以外なら何もしないで終了
If TypeName(Selection) <> "Range" Then Exit Sub

Dim myCells As Range: Set myCells = Selection
Dim tlCell As Range: Set tlCell = myCells.Cells(1) '左上のセル

'テキストボックス作成
Dim myTB As Shape
Set myTB = ActiveSheet.Shapes.AddTextbox( _
msoTextOrientationHorizontal, _
tlCell.Left, tlCell.Top, 100, 10)
myTB.TextFrame.AutoSize = True 'オートサイズを有効にする
myTB.Placement = xlMove 'セルに合わせて移動するけどサイズ変更しない
' myTB.Placement = xlFreeFloating '移動もサイズ変更もしない

'テキストボックスに表示する文字列を作成
Dim str As String
Dim rRow As Range
str = testGetString2(myCells)
'テキストボックスにテキスト指定
myTB.TextFrame2.TextRange.text = str

'フォントカラーとフォントの設定
Call SetFontColorAndFont(myTB, myCells)
'セル幅に合わせたタブ位置を設定する
Call AddTabPosition(myTB, myCells)

End Sub

'渡されたセル範囲の値(text)を表形式用に繋げて返す
'1行の値はタブ文字で繋げて、行が変わったら改行文字でつなげる
Function testGetString2(r As Range) As String
Dim str As String
Dim rr As Range
Set rr = r.Cells.Rows(1)
'先頭にタブ文字を入れているのは
'文字の水平位置が左寄せの他にも対応するためで
'これがないと最初の文字列が必ず0から始まってしまい
'もし最初のセルが左寄せ以外のときでも0になってしまうから
str = vbTab & GenerateString(rr, True)

'2行以上あるとき
If r.Rows.Count > 1 Then
Dim i As Long
For i = 2 To r.Rows.Count
Set rr = r.Cells.Rows(i)
str = str & vbNewLine & vbTab & GenerateString(rr, True)
Next
End If
testGetString2 = str

End Function

'文字列生成、
'渡されたセル範囲にある文字列を繋げて返す
'渡すセル範囲は1行か1列のどちらか
'horiはHorizontalで
'Trueならタブ文字でつなげる
'Falseなら改行文字でつなげる
Function GenerateString(r As Range, Optional hori As Boolean = False) As String
Dim str As String
str = r.Cells(1).text
If r.Cells.Count = 1 Then
GenerateString = str
Exit Function
End If
'2セル以上のとき
Dim i As Long
If hori Then
'タブ文字でつなげる
For i = 2 To r.Cells.Count
str = str & vbTab & r.Cells(i).text
Next
Else
'改行文字でつなげる
For i = 2 To r.Cells.Count
str = str & vbNewLine & r.Cells(i).text
Next
End If
GenerateString = str
End Function

'テキストボックスのフォントカラーとフォントをセルと同じにする
'sはテキストボックス(図形)、tableRにはセル範囲を渡す
Sub SetFontColorAndFont(s As Shape, tableR As Range)
Dim i As Long, j As Long, k As Long
Dim r As Range, rowR As Range
Dim p As TextRange2

'Paragraph(1行)ごとに処理
'Paragraphの文字列はtab, text, tab, text...って並んでいる
For k = 1 To tableR.Rows.Count
Set p = s.TextFrame2.TextRange.Paragraphs(k)
Set rowR = tableR.Cells.Rows(k) '1行
Dim cStart As Long '処理する文字のスタート位置
'最初の文字はタブ文字で色は関係ないのでスタート位置は1
cStart = 1
'1セルごとに処理
Dim char As TextRange2 ' Characters
For i = 1 To rowR.Cells.Count
Set r = rowR.Cells(i) '1セル
'対象となる1セルに対応した文字列
Set char = p.Characters(cStart + 1, Len(r.text))
'セルのフォントカラーがNullなら複数の色が指定されているので
'1文字ごとに色指定する
If IsNull(r.Font.Color) Then
For j = 1 To char.Length
char.Characters(j, 1).Font.Fill.ForeColor.Rgb _
= r.Characters(j, 1).Font.Color'1文字色指定
Next
Else
'1セルごとに色指定
char.Font.Fill.ForeColor.Rgb = r.Font.Color
End If

'1セルごとにフォント設定
With char.Font
.Name = r.Font.Name
.NameFarEast = r.Font.Name
.Size = r.Font.Size
End With
'次に処理する文字のスタート位置
cStart = cStart + Len(r.text) + 1
Next
Next k
End Sub

'図形の中のテキストにタブ位置を追加
'セル範囲と図形を渡す
'セル幅を使うのでテキストとセルの値が対応している必要がある
Sub AddTabPosition(tb As Shape, r As Range)
Call ClearTabStops(tb) 'タブ位置をすべて消去
Dim ps As TextRange2
Set ps = tb.TextFrame2.TextRange.Paragraphs
Dim i As Long
'1行ごとにタブ位置を追加
For i = 1 To ps.Count
'タブの既定値は邪魔なので0にする
ps.Item(i).ParagraphFormat.TabStops.DefaultSpacing = 0
'1行ごとタブ位置追加
'Call AddTabPositionSub(ps.Item(i), r.Cells.Rows(i))
'中央揃え対応版
Call AddTabPositionSub2(ps.Item(i), r.Cells.Rows(i))
Next
End Sub

'タブ位置すべてをクリア
'渡された図形の中のテキストのタブ位置を消去
Sub ClearTabStops(s As Shape)
'図形にテキストがなければ何もしないで終了
If s.TextFrame2.HasText = msoFalse Then Exit Sub
Dim ps As TextRange2
Set ps = s.TextFrame2.TextRange.Paragraphs
Dim tss As TabStops2
Dim i As Long
Dim ts As TabStop2
For i = 1 To ps.Count
Set tss = ps.Item(i).ParagraphFormat.TabStops
For Each ts In tss
ts.Clear
Next
Next
End Sub

'タブ位置を追加、位置はセル幅を元に設定する
'左揃え、中央揃え、右揃えに対応
'pfはParagraph、rは1行のセル範囲
'AddTabPositionと一緒に使う
Sub AddTabPositionSub2(pf As TextRange2, r As Range)
Dim po As Single 'タブ位置Position
Dim tss As TabStops2
Set tss = pf.ParagraphFormat.TabStops
Dim nowR As Range: Set nowR = r.Cells(1)
'先頭のタブ位置を追加
Call SetTabStop(nowR, tss, 0)
po = tss.Item(1).Position

'セルが1個だけのときはここで終了
If r.Cells.Count = 1 Then Exit Sub

'セルが2個以上のとき
'2番目以降のタブ位置を追加
Dim beforeR As Range
Dim i As Long
For i = 2 To r.Cells.Count
Set beforeR = r.Cells(i - 1)
Set nowR = r.Cells(i)

'1つ前のタブ位置に1つ前のセル幅を足す
'これが次のタブ位置の基準になる
po = po + beforeR.Width

'タブ位置の調整
If beforeR.HorizontalAlignment = xlCenter Then
'1つ前のセルが中央揃えのとき、1つ前のセル幅の半分をひく
po = po - (beforeR.Width / 2)
ElseIf beforeR.HorizontalAlignment = xlRight _
Or (IsNumeric(beforeR.Value2) _
And beforeR.HorizontalAlignment = xlGeneral) Then
'１つ前のセルが右揃えのとき、１つ前のセル幅分をひく、4は調整
po = po - beforeR.Width + 4
End If

'タブ位置を追加する
Call SetTabStop(nowR, tss, po)
Next
End Sub

'タブ位置を調整してから追加
'セルのHorizontalAlignmentとセル幅に依って調整
Sub SetTabStop(r As Range, tss As TabStops2, po As Single)
'タブ位置を追加する
If r.HorizontalAlignment = xlCenter Then
'セルが中央揃えのとき、セル幅の半分を足す
po = po + (r.Width / 2)
tss.Add msoTabStopCenter, po
ElseIf r.HorizontalAlignment = xlRight _
Or (IsNumeric(r.Value2) _
And r.HorizontalAlignment = xlGeneral) Then
'右揃えか数値(指定なしだと数値は通常右揃え)のときだけは
'調整で-4、こうしておくと右揃えの次に左揃えが来たときに
'タブ位置が重なること防ぐことになるし、見た目も良くなる
po = po + r.Width - 4
tss.Add msoTabStopRight, po
Else
'左揃えか指定なしの文字列のとき
tss.Add msoTabStopLeft, po
End If
End Sub