エクセルVBAで使うコードの備忘録。VBAでワードファイルを操作して、シェイプオブジェクト内の文字列を置換するコード。今回は本文内ではなく、ヘッダーやフッター内に配置されたシェイプオブジェクトのテキストを置換します。
事前準備
VBAでワードファイルを操作するには、参照設定が必要です。VBAのコードエディタから「ツール > 参照設定」と進み、「Microsoft Word XX.X Object Library」にチェックを入れておきます。
ヘッダー内のシェイプオブジェクトを置換
基本的な考え方は本文中のシェイプオブジェクトのテキストを置換する時と同様です。ヘッダー内に含まれるすべてのシェイプオブジェクトを順番に検索して、対象となる文字列を見つけた場合は置換をするというようにコーディングすればよいです。本文中のシェイプオブジェクトを置換した時と同様に考えなければならないのは、描画キャンパスとグループ化されたオブジェクトへの対応です。対象とする文書内でこのような形態のシェイプオブジェクトを使わないのであれば無視して問題ありませんが、汎用的に使うことを想定しているのであれば対応は不可避です。
下記のコードでは、まずシェイプオブジェクトが描画キャンパスか、グループか、そうでないかで場合分けしています。描画キャンパスの場合はさらにその内部をループしてシェイプオブジェクトを検索し、見つかったシェイプオブジェクトに対してこちらもグループかそうでないかで場合分けします。グループの場合は、グループ化されているシェイプオブジェクトを全て検索してやります。
ヘッダーのシェイプオブジェクトで考えなければいけないもう一つの点は、シェイプオブジェクトがセクションごとに分けて格納されているという点です。ワードの文書ではセクションが分かれるとヘッダーも分けられるよう設定できることに合わせた設計になっているため、ヘッダー内のシェイプオブジェクトすべてを検索するためには、すべてのセクションに対して検索をかけてやる必要があります。
なお、サンプルコードを使用する際はカッコに囲まれた部分（[***]）を自分のプログラムに合わせて変更してください。
サンプルコード
Public Sub RepleceTexts()
'--- Wordのアプリケーションオブジェクト ---'
Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'--- ドキュメントオブジェクト ---'
Dim objDoc As Word.Document
Set objDoc = objWord.Documents.Open("[ワードファイルのパス]")
'--- 置換前の文字列 ---'
Dim srcText As String
srcText = "[置換前の文字列]"
'--- 置換後の文字列 ---'
Dim replaceText As String
replaceText = "[置換後の文字列]"
'--- 全てのセクションをループ ---'
Dim i As Long
Dim j As Long
For i = 1 To objDoc.Sections.Count
For j = 1 To objDoc.Sections(i).Headers.Count
'--- 文書ないにあるすべてのシェイプオブジェクトに対してループ ---'
Dim shp As Variant
For Each shp In objDoc.Sections(i).Headers(j).Shapes
'--- シェイプオブジェクトが描画キャンバスの場合 ---'
If shp.Type = msoCanvas Then
'--- 描画キャンパス内のすべてのアイテムに対してループ ---'
Dim cvsShp As Shape
For Each cvsShp In shp.CanvasItems
'--- グループ化されている場合は再度ループ ---'
If cvsShp.Type = msoGroup Then
Dim cvsGrpShp As Variant
For Each cvsGrpShp In cvsShp.GroupItems
Call ReplaceShapeText(cvsGrpShp, srcText, replaceText)
Next
Else
Call ReplaceShapeText(cvsShp, srcText, replaceText)
End If
Next
'--- グループ化されている場合 ---'
ElseIf shp.Type = msoGroup Then
Dim grpShp As Variant
For Each grpShp In shp.GroupItems
Call ReplaceShapeText(grpShp, srcText, replaceText)
Next
'--- ただのシェイプオブジェクトの場合 ---'
Else
Call ReplaceShapeText(shp, srcText, replaceText)
End If
Next
Next j
Next i
'--- ドキュメントを閉じる ---'
objDoc.Close
'--- ワードを閉じる ---'
objWord.Quit
End Sub
'--- 引数として与えられたシェイプオブジェクトを置換する関数 ---'
Public Sub ReplaceShapeText(shp As Variant, srcText As String, replaceText As String)
If shp.TextFrame.HasText Then
Dim objFind As Find
Set objFind = shp.TextFrame.TextRange.Find
objFind.ClearFormatting
objFind.Forward = True
objFind.Text = srcText
objFind.Replacement.Text = replaceText
Call objFind.Execute(Replace:=wdReplaceAll)
End If
End Subフッター内のシェイプオブジェクトを置換
フッター内のシェイプオブジェクトを置換する場合は、上記のヘッダー内の場合のコードの中で「Headers」になっている部分を「Footers」に変える２ヶ所だけです。ほとんど変わりませんが、一応サンプルコードを下記に記しておきます。
サンプルコード
Public Sub RepleceTexts()
'--- Wordのアプリケーションオブジェクト ---'
Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'--- ドキュメントオブジェクト ---'
Dim objDoc As Word.Document
Set objDoc = objWord.Documents.Open("[ワードファイルのパス]")
'--- 置換前の文字列 ---'
Dim srcText As String
srcText = "[置換前の文字列]"
'--- 置換後の文字列 ---'
Dim replaceText As String
replaceText = "[置換後の文字列]"
'--- 全てのセクションをループ ---'
Dim i As Long
Dim j As Long
For i = 1 To objDoc.Sections.Count
For j = 1 To objDoc.Sections(i).Footers.Count
'--- 文書ないにあるすべてのシェイプオブジェクトに対してループ ---'
Dim shp As Variant
For Each shp In objDoc.Sections(i).Footers(j).Shapes
'--- シェイプオブジェクトが描画キャンバスの場合 ---'
If shp.Type = msoCanvas Then
'--- 描画キャンパス内のすべてのアイテムに対してループ ---'
Dim cvsShp As Shape
For Each cvsShp In shp.CanvasItems
'--- グループ化されている場合は再度ループ ---'
If cvsShp.Type = msoGroup Then
Dim cvsGrpShp As Variant
For Each cvsGrpShp In cvsShp.GroupItems
Call ReplaceShapeText(cvsGrpShp, srcText, replaceText)
Next
Else
Call ReplaceShapeText(cvsShp, srcText, replaceText)
End If
Next
'--- グループ化されている場合 ---'
ElseIf shp.Type = msoGroup Then
Dim grpShp As Variant
For Each grpShp In shp.GroupItems
Call ReplaceShapeText(grpShp, srcText, replaceText)
Next
'--- ただのシェイプオブジェクトの場合 ---'
Else
Call ReplaceShapeText(shp, srcText, replaceText)
End If
Next
Next j
Next i
'--- ドキュメントを閉じる ---'
objDoc.Close
'--- ワードを閉じる ---'
objWord.Quit
End Sub
'--- 引数として与えられたシェイプオブジェクトを置換する関数 ---'
Public Sub ReplaceShapeText(shp As Variant, srcText As String, replaceText As String)
If shp.TextFrame.HasText Then
Dim objFind As Find
Set objFind = shp.TextFrame.TextRange.Find
objFind.ClearFormatting
objFind.Forward = True
objFind.Text = srcText
objFind.Replacement.Text = replaceText
Call objFind.Execute(Replace:=wdReplaceAll)
End If
End Sub