Wordで文字列を四角で囲むときにテキストボックスを使うケースがあります。
しかしこれには問題があって、例えば、複数のテキストボックスのテキストをまとめてコピーしようとして「全てを選択してコピー」としても、本文のテキストしか選択されません。
そこでテキストボックスのテキストを一括して抽出するマクロを考えてみました。
単純に抽出するとテキストボックスを作成した順になってしまいますので、一度、すべてを抽出し、その後、位置情報を使い、上から順に、左から順に並べ替えるようにしました。
実行すると文書内のテキストボックスのテキストを本文の末尾に連続して貼り付けます。
Type textbox
text As String
top As Long
left As Long
End Type
Sub テキストボックスのテキストを抽出()
Dim boxes() As textbox
Dim numofshape, i As Long
With ActiveDocument.Content
.InsertAfter "【テキストボックス】"
.InsertParagraphAfter
numofshape = ActiveDocument.Shapes.Count
ReDim boxes(numofshape - 1)
For i = 0 To numofshape - 1
With ActiveDocument.Shapes(i + 1)
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
boxes(i).text = .TextFrame.TextRange.text
boxes(i).top = .top
boxes(i).left = .left
End With
Next i
Call sort_textbox(boxes)
For i = 0 To numofshape - 1
.InsertAfter boxes(i).text
.InsertParagraphAfter
Next i
End With
End Sub
Function sort_textbox(ar() As textbox)
Dim temp As textbox
Dim i, j As Long
For i = 0 To UBound(ar) - 1
For j = i + 1 To UBound(ar)
If ar(i).top > ar(j).top Or _
(ar(i).top = ar(j).top And ar(i).left > ar(j).left) Then
temp = ar(i)
ar(i) = ar(j)
ar(j) = temp
End If
Next j
Next i
End Function
text As String
top As Long
left As Long
End Type
Sub テキストボックスのテキストを抽出()
Dim boxes() As textbox
Dim numofshape, i As Long
With ActiveDocument.Content
.InsertAfter "【テキストボックス】"
.InsertParagraphAfter
numofshape = ActiveDocument.Shapes.Count
ReDim boxes(numofshape - 1)
For i = 0 To numofshape - 1
With ActiveDocument.Shapes(i + 1)
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
boxes(i).text = .TextFrame.TextRange.text
boxes(i).top = .top
boxes(i).left = .left
End With
Next i
Call sort_textbox(boxes)
For i = 0 To numofshape - 1
.InsertAfter boxes(i).text
.InsertParagraphAfter
Next i
End With
End Sub
Function sort_textbox(ar() As textbox)
Dim temp As textbox
Dim i, j As Long
For i = 0 To UBound(ar) - 1
For j = i + 1 To UBound(ar)
If ar(i).top > ar(j).top Or _
(ar(i).top = ar(j).top And ar(i).left > ar(j).left) Then
temp = ar(i)
ar(i) = ar(j)
ar(j) = temp
End If
Next j
Next i
End Function
コメント
このマクロに期待していましたが、Word2003でも2010でも同様のエラーが出ます。
boxes(i).text = .TextFrame.TextRange.textでテキストの添付をサポートしていませんというエラーです。どのword対応でしょうか。2003/2010で何か不足している場合はご教授ください。
よろしくお願いします。
On Error Resume Nextの追加で問題なく、通過しました。実は、実行時エラー5917がその前にあり、見過ごしていました。業務でワードからエクセルにテーブルを移行しているのですが、テーブル内にテキストボックスが使用されており、苦戦しています。
>大野さん
Word2007です。
テキストボックスの多用は後で困りますよね。