(Wordマクロ)テキストボックスを追加する(CreateTextbox)

Wordでテキストボックスを追加する方法のうち、Selection.CreateTextboxメソッドを紹介します。Excelでも使えるAddTextboxメソッドについては、テキストボックスを追加するを参考にしてください。




メソッドの機能

解説

Selection.CreateTextboxメソッドは、下の画像の赤囲み部分と似た働きをします。

しかし、完全に同一の働きをするわけではありません

無選択状態の場合

無選択状態でSelection.CreateTextboxメソッドを実行すると、カーソルが十字になり、自由にテキストボックスを描ける状態となります。
しかし、この状態ではテキストボックスは描画されていないため、次のコードを実行すると下の画像のようにエラーが表示されます。

Public Sub テキストボックスを描画する()
With Selection
.CreateTextbox
.ShapeRange(1).Line.DashStyle = msoLineDashDot '無選択状態ではエラー
End With
End Sub

<無選択状態における実行結果>

選択状態の場合

選択状態でSelection.CreateTextboxメソッドを実行すると、選択範囲の周囲にテキストボックスが追加されます。

手動で「横書きテキストボックスの描画」を実行すると文字の範囲に適したテキストボックスが生成されますが、CreateTextBoxメソッドを実行した生成されたテキストボックスは、既定の大きさのテキストボックスです
当方の環境では常に50.8mmのテキストボックスが生成されましたが、もしかしたらWordのバージョンによって多少の差異があるかもしれません。

<手動で「横書きテキストボックスの描画」を実行した場合>

<CreateTextboxメソッドを実行した場合>

これでは使い物にならないという方がほとんどだと思いますので、CreateTextboxメソッドを実行した後に、文字数などに応じてテキストボックスの枠を調節するマクロを考えてみました。
手動で実行したときと完全に同じ挙動をするわけではありませんが、ほとんどの場合で問題が出ないようにコードを組んであります。

テキストボックスの枠を自動調節するマクロ

Option Explicit
Type PageSetupValue
    CharactersLine As Long
    PageWidth As Long
    PageHeight As Long
    LeftMargin As Long
    RightMargin As Long
    TopMargin As Long
    BottomMargin As Long
    LinesPage As Long
End Type

Public Sub テキストボックスを描画する()
'変数定義
Dim FontSize As Single 'フォントサイズ
Dim CharacterCount As Long '選択範囲の文字数
Dim Correction As Single '補正値
Dim LineMulti As Long '行数
Dim PageValues As PageSetupValue
Dim flag As Boolean

'PageSetupの値取得
With ActiveDocument.PageSetup
PageValues.CharactersLine = .CharsLine '1行の文字数
PageValues.PageWidth = .PageWidth 'ページの幅
PageValues.PageHeight = .PageHeight 'ページの高さ
PageValues.LeftMargin = .LeftMargin '左余白
PageValues.RightMargin = .RightMargin '右余白
PageValues.TopMargin = .TopMargin '上余白
PageValues.BottomMargin = .BottomMargin '下余白
PageValues.LinesPage = .LinesPage '1ページあたりの行数
End With

'初期値
LineMulti = 1

With Selection
Select Case True
Case .Type <> wdSelectionNormal
'選択していない場合または表などを選択していた場合は処理を抜けます
    Exit Sub
Case .Characters.Count > PageValues.CharactersLine - 1
If .Range.ComputeStatistics(wdStatisticWords) > PageValues.CharactersLine - 1 Then
'1行の文字数-1以上の文字・単語を選択している場合は、その行数を計算します
    LineMulti = .Characters.Count / (PageValues.CharactersLine - 1)
Else
'文字数は1行を超えているが、単語数は1行内に収まる場合は例外処理とします
    flag = True
End If
End Select

'補正値処理
If InStr(Selection, vbCr) <> 0 Then
'改行記号を含んでいる場合は1文字分幅を広げます
    Correction = .Characters.Count + 1
Else
'改行記号を含んでいない場合は2文字分幅を広げます
    Correction = .Characters.Count + 2
End If

FontSize = .Font.Size * 0.35 '1pt=0.35mm
CharacterCount = .Characters.Count '文字数カウント
.CreateTextbox 'テキストボックスの生成

'テキストボックスの幅設定
If LineMulti = 1 And flag = False Then '1行のみの場合
    .ShapeRange(1).Width = MillimetersToPoints(FontSize * Correction)
Else '複数行にまたがる場合
    .ShapeRange(1).Width = PageValues.PageWidth - _
    (PageValues.LeftMargin + PageValues.RightMargin)
End If

'テキストボックスの高さ設定
If LineMulti = 1 And flag = False Then '1行のみの場合
    .ShapeRange(1).Height = MillimetersToPoints(.ParagraphFormat.LineSpacing * LineMulti / 2)
Else
Select Case .ParagraphFormat.LineSpacingRule
Case wdLineSpaceExactly '固定値
    LineMulti = LineMulti * 0.8
    .ShapeRange(1).Height = MillimetersToPoints(.ParagraphFormat.LineSpacing * LineMulti / 2)
Case wdLineSpace1pt5, wdLineSpaceDouble, wdLineSpaceMultiple  '1.5行、2行、倍数
    LineMulti = LineMulti + 1
    .ShapeRange(1).Height = MillimetersToPoints(.ParagraphFormat.LineSpacing * LineMulti / 1.5)
Case wdLineSpaceSingle, wdLineSpaceAtLeast '1行、最小値
    LineMulti = LineMulti + 1
    .ShapeRange(1).Height = (PageValues.PageHeight - _
    (PageValues.TopMargin + PageValues.BottomMargin)) / _
    PageValues.LinesPage * (LineMulti + 1)
End Select
End If
End With
End Sub

次のページで上記コードの解説をしています。

おすすめ

コメントを残す

メールアドレスが公開されることはありません。

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください