図形のテキストボックスのタブ文字、タブ位置とかのメモ、選択セル範囲を1つのテキストボックスにするマクロ

図形のテキストボックスのタブ文字、タブ位置とか調べてみた結果

よくわからん(´・ω・｀)

エクセル2007は図形に対するマクロの記録ができなくてめんどくさいのでメモ

このテキストボックスにはa1タブ文字a2タブ文字a3って入っている

テキストボックスのタブの間隔の設定は

テキストボックスShape.TextFrame2.TextRange.ParagraphFormat.TabStops

ってところにあるこのTabStops

TabStopsの中を見てみる

DefaultSpacing = 72

これがタブの間隔

普通に

テキストボックスのタブの間隔の設定

テキストボックスの右クリックメニュー→

段落→

インデントと行間隔タブのタブとリーダー→

既定値

この既定値がさっきのDefaultSpacingになっているみたい

既定値2.54とDefaultSpacing72の結果は同じで

それぞれの数値の単位はセンチメートルとポイントなのかも

DefaultSpacingを72から20にすると

文字間隔が狭くなる

既定値の方も2.54から0.71へと値が小さくなっている

タブ位置

既定値とは別のタブ位置を追加するのが

タブ位置の設定(追加)

タブの設定画面のタブ位置に数値を入れて

設定ボタンを押すと追加される

タブ位置を設定した結果

1つだけ追加して、それぞれ1センチと2センチ3センチにしてみた結果

1と2センチはa2だけが移動して

3センチはa2,a3ともに移動した

1センチを追加したテキストボックスのTabStopsをみてみる

新しくItem 1ってのが追加されている

その中のPositionがタブ位置のことで

数値28.34646ってのが1センチを表すポイントみたい

タブ位置を2つ追加

1センチと2センチ

1センチと2センチを追加したら等間隔になった

ってことは前の文字列からの距離じゃなくて一番最初の文字列からの距離

1センチと3センチ

どうやら追加したタブ位置ってのは前の文字列からじゃなくて

最初の文字列からの距離みたい

タブ位置1センチのところに文字列を追加してみる

a2のタブ位置が1センチになっているところに

最初の文字列a1に文字を追加してみる

3文字追加したところ

4文字目だとa2に重なりそうだけど

4文字目追加したらa2が離れた

この距離はどう見ても1センチじゃなから既定値の数値っぽい

複数行のとき

指定したタブ位置はすべての行に適用されるみたい

ここで1行目の最初の文字列に文字を追加してみると

1行目だけタブ位置が変更された

できれば2行目も移動してほしい

タブ位置指定なしのとき

タブ位置指定なしで既定値だけのとき

同じように文字を足していくと

同じ挙動だった…

例えば既定値が5のときのタブの位置は行の先頭からの距離で

5, 10, 15, 20, 25, …ってずーっと続いていて

タブ位置の設定で追加されるのは、この続いている中に追加される

1センチのところに設定したら

1, 5, 10, 15…ってなって

さらに12センチにも設定したら

1, 5, 10, 12, 15…ってなる

この設定の時の文字列の位置は

最初の文字列の長さが1センチを超えていなければ

2番めの文字列は1センチのタブ位置になって、超えていたら

2番めの文字列は5センチのタブ位置になって

2番めの文字列末尾が10センチのところのタブ位置を超えていなければ

3番めの文字列は10センチのタブ位置になって、超えていたら

3番めの文字列は12センチのタブ位置になって

こんなかんじかなあ

まとめると

既定値ってのがテキストエディタとかにもある普通のタブ位置のことで

その中に別のタブ位置を1つ1つ追加するのがタブ位置の設定

選択したテキストボックスのタブの既定値を20に変更するマクロ

Sub ChangeTabSpace()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
Dim tss As TabStops2
Set tss = s.TextFrame2.TextRange.ParagraphFormat.TabStops
tss.DefaultSpacing = 20 'タブの既定値変更
End Sub

↑を1行で書くと↓

Sub ChangeTabSpace2()
Selection.ShapeRange.Item(1).TextFrame2.TextRange.ParagraphFormat.TabStops.DefaultSpacing = 20 'タブの既定値変更
End Sub

選択したテキストボックスにタブ位置20ポイントを追加するマクロ

Sub AddTabStop()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
Dim tss As TabStops2
Set tss = s.TextFrame2.TextRange.ParagraphFormat.TabStops
tss.Add msoTabStopLeft, 20 'タブ位置追加
End Sub

'タブ位置すべてを消去するマクロ(2017/01/17に修正)

Sub DeleteTabStops()
Dim s As Shape
Set s = Selection.ShapeRange.Item(1)
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

なんでこんなこと調べているのか

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

こんなふうにしたい

表をそのままの形でテキストボックス

試しに書いてみた

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

Sub testTableTextBox()
      '選択されているのがセル以外なら何もしないで終了
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim myCells As Range
    Set myCells = Selection
    Dim tlCell As Range
    Set tlCell = myCells.Cells(1) '左上のセル
    
     'テキストボックスに表示する文字列を作成
    Dim str As String
    Dim rRow As Range
    str = testGetString(myCells)
    
    'テキストボックス作成
    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 '移動もサイズ変更もしない
    
    With myTB.TextFrame2.TextRange
        .text = str
'       フォントの指定(選択セルのフォントと同じ)
        Dim myFont As Font: Set myFont = tlCell.Font
        With .Font
            .Name = myFont.Name
            .NameFarEast = myFont.Name
            .Size = myFont.Size
        End With
    End With
End Sub


'渡されたセル範囲の値(text)を表形式用に繋げて返す
'1行の値はタブ文字で繋げて、行が変わったら改行文字でつなげる
Function testGetString(r As Range) As String
    Dim str As String
    Dim rr As Range
    Set rr = r.Cells.Rows(1)
    str = 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 & GenerateString(rr, True)
        Next
    End If
    testGetString = 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

Sub testTableTextBox()
'選択されているのがセル以外なら何もしないで終了
If TypeName(Selection) <> "Range" Then Exit Sub

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

'テキストボックスに表示する文字列を作成
Dim str As String
Dim rRow As Range
str = testGetString(myCells)

'テキストボックス作成
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 '移動もサイズ変更もしない

With myTB.TextFrame2.TextRange
.text = str
' フォントの指定(選択セルのフォントと同じ)
Dim myFont As Font: Set myFont = tlCell.Font
With .Font
.Name = myFont.Name
.NameFarEast = myFont.Name
.Size = myFont.Size
End With
End With
End Sub

'渡されたセル範囲の値(text)を表形式用に繋げて返す
'1行の値はタブ文字で繋げて、行が変わったら改行文字でつなげる
Function testGetString(r As Range) As String
Dim str As String
Dim rr As Range
Set rr = r.Cells.Rows(1)
str = 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 & GenerateString(rr, True)
Next
End If
testGetString = 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