Word文書のワードアートのテキストをマクロで変更

お世話になります。
Word文書のワードアートのテキストをExcelマクロで変更する方法を教えてください。

Wordアプリケーションへの参照と、該当Word文書への参照と、変更したいテキストがあります。

試したこと：
１）Word2007で、マクロを記録してからワードアートのテキストを変更してみたが、マクロには何も記録されなかった。
２）該当Word文書のShapes　や　InlineShapes　を参照してMsgboxで表示してみたが、テキストボックスに設定したテキストしか画面に表示されなかった。

何をやっているのか？：
教室のパンフレットを作ろうとしています。同じような書式で、曜日とか時間とか講座名とか費用とか・・だけ違うパンフレットを大量に作るのですが、いちいちデータを変更していると面倒なので、
Excelシートにデータを出力しておいて、Wordで作った雛形のなかの、曜日とか時間とか講座名とか費用とかの部分だけ変換してやればいいじゃないか、と考えたわけです。

そこで、Excelシートのどのシートのどのセルに、曜日とか時間とか講座名とか費用とか・・・が入っているかというデータを用意しまして、そのブック（ブックM）に、こんなマクロを作ったのです。
１．Excelデータ（ブックD）をオープン
２．ワード文書の雛形をオープン
３．ブックMの１行目から順に・・・
　　３－１．曜日とか時間とか・・という項目名などを取得
　　３－２．ブックDから該当するデータを取得
　　３－３．データの先頭や末尾の、不要な部分を適宜切捨て
　　３－４．ワード文書で置換を実行

こんな感じのマクロです。
ワード文書の雛形には、「開講する講座：#講座名#(#コース名#)」などと記述してありますので、
#講座名#を「陶芸を楽しむ」　　#コース名#を「入門」　などと変更してやれば、パンフレットが出来上がるのです。

しかし、ワードアートのテキストを#講座名#にしておいても変更されないし、マクロの記録もできないし・・で困っております。

お答えをいただければ幸いです。

No.1 回答者： imogasi 回答日時： 2011/03/03 22:20

あまりVBAでやったことがない領域だが

まずエクセルででも出来ると思う。ワード・エクセル両方にまたがらせないほうがやさしいのは当然。
ーー
下記を応用できないか考えてみて。
標準モジュールに（マクロの記録を参考にしている）
Sub Macro3()
s = Array("大きな文字", "綺麗な文字", "赤い文字です")
For i = 1 To 3
ActiveSheet.Shapes.AddTextEffect(msoTextEffect22, s(i - 1), "ＭＳ Ｐゴシック", 36#, _
msoFalse, msoFalse, 343.5, 240.75).Select
Next i
End Sub
で”大きな文字", "綺麗な文字", "赤い文字です”という文字を入れたワードアートが３つシートにできる。
位置は考慮してません。
表示位置はマクロの記録でも採って、その値をまねてください。
ーーー
ここで
Sub test02()
For i = 1 To 3
ActiveSheet.Shapes(i).TextEffect.Text = Range("A" & i).Value
Next i
End Sub
を実行すると、セルA1:A3に入っている文字にそれぞれ置き換わる。
（変な文句だが意味なし）
A1:A3
近くの公園
大きな公園
円い池２つ
を入れておく。
実行後は、"近くの公園","大きな公園","円い池２つ"の文字のワードアートに変わった。
Shapesの種類が、色々シートに作られていると、このコードのままでは動かないと思うが、あとは質問者にお任せする。
For i = 1 To 3の３はShapesのCountで、状態の事実から決められるだろう。

この回答への補足

文書の提出先が「全国各地から集めるからWordでなきゃ困る」と言っておりまして・・。
Word文書でもShapes(i).TextEffect.TextなりInLineShapes(i)の何かなりを設定すればよさそうですので、ちょっと応用させていただきます。

多少はまともに動くようになったらソースコードとともにお礼に伺います。

補足日時：2011/03/13 07:17

この回答へのお礼

遅くなりました。ようやく「多少」動くようになりましたのでこちらのコードも公開させていただきます。

参考になるコードをありがとうございました。

'オートシェイプも変更をかける
Sub doChangeShapeText(myDoc As Word.Document, ByVal strReplace As String, ByVal strData As String)

Dim tmpStr As String
Dim idx As Integer
Dim idxStr As Integer

For idx = 1 To myDoc.Shapes.Count
If myDoc.Shapes(idx).Type = MsoShapeType.msoTextEffect Then
tmpStr = myDoc.Shapes(idx).TextEffect.Text
idxStr = InStr(tmpStr, strReplace)
If idxStr > 0 Then
tmpStr = Left(tmpStr, idxStr - 1) _
& strData _
& Mid(tmpStr, idxStr + Len(strReplace))
myDoc.InlineShapes(idx).TextEffect.Text = tmpStr
End If
ElseIf (True = myDoc.Shapes(idx).TextFrame.HasText) Then
tmpStr = myDoc.Shapes(idx).TextFrame.TextRange.Text
idxStr = InStr(tmpStr, strReplace)
If idxStr > 0 Then
tmpStr = Left(tmpStr, idxStr - 1) _
& strData _
& Mid(tmpStr, idxStr + Len(strReplace))
myDoc.Shapes(idx).TextFrame.TextRange.Text = tmpStr
End If
End If
DoEvents
Next

For idx = 1 To myDoc.InlineShapes.Count
On Error GoTo lpNext:
If myDoc.InlineShapes(idx).Type = wdInlineShapePicture Then
tmpStr = myDoc.InlineShapes(idx).TextEffect.Text
idxStr = InStr(tmpStr, strReplace)
If idxStr > 0 Then
tmpStr = Left(tmpStr, idxStr - 1) _
& strData _
& Mid(tmpStr, idxStr + Len(strReplace))
myDoc.InlineShapes(idx).TextEffect.Text = tmpStr
End If
End If
lpNext:
DoEvents
Next
End Sub

お礼日時：2011/04/05 19:37