この記事では、マーカー「【★☆★図1★☆★】」を、元の行内図に置き換えます。
▼このマクロでできること
上記のマーカーの記載されたファイルを開いた状態でマクロを実行します。
マクロを実行するとファイルを選択するダイアログボックスが開くので、元の図が記載されているファイルを選択します。
この選択したファイル内の図を用いて、現在開かれているWordファイル内のマーカーを置き換えます。
マーカーが見つからない場合には、マクロ実行後にその図番号を表示をします。
▼マクロの解説
Wordファイルを選択します。
このときの記載方法は、記事「【Wordマクロ】ファイル選択ダイアログボックスの工夫 」をご覧ください。
ファイルを選択して内部の情報を取得することってよくあります。
そのときにWordファイルをそのまま開いてしまうと、そのファイルを何らかの理由で壊してしまうかもしれません。文字列を書き換えてしまうかもしれません。
そのようなリスクを冒さずに内容を見るために以下の2つの技を使うと便利です。
１．非表示にして開く
２．既存の文書から新規ファイルを開く
非表示にすれば、私たちがカーソルを置いてファイルを触ってしまうというリスクを回避できます。
また、画面がちらつくこともないので、その点でもいいですね。
既存文書をもとにして新規ファイルで開けば、同じファイルを全く別のファイルとして開くことができます。
参考記事「【Wordマクロ】既存の文書から新規作成する 」
万が一、このファイルを壊したとしても、元のファイルには何の影響もありません。安全です。
開いたファイルをmyDocというオブジェクト変数に入れます。
あとは、このファイル内の図を用いて、現在開かれているファイルのマーカーを置き換えるだけです。
▼マクロ
Sub マーカーを行内図に置き換える()
Dim myFilePath As String ' Wordファイルのパス
Dim myFD As FileDialog
Dim vrtSelectedItem As Variant
Dim myDoc As Document
Dim iMax As Integer '選択したWordファイル内の図の数
Dim i As Integer
Dim myRange As Range
Dim myErr As String '図が見つからない場合の表示
'------------------------------------------------
'Wordファイルの選択
'------------------------------------------------
Set myFD = Application.FileDialog(msoFileDialogFilePicker)
With myFD
.AllowMultiSelect = False
.Title = "原文のWordファイルを選択してください"
With .Filters
.Clear
.Add "すべてのWordファイル", "*.doc; *.docx"
End With
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
myFilePath = vrtSelectedItem
Next
With .Filters
.Clear
.Add "すべてのファイル", "*.*"
End With
Else
With .Filters
.Clear
.Add "すべてのファイル", "*.*"
End With
'マクロを終了
Exit Sub
End If
End With
Set myFD = Nothing
'選択したファイルをテンプレートにしてファイルを開く（非表示）
Set myDoc = Documents.Add(Template:=myFilePath, Visible:=False)
'------------------------------------------------
'マーカーを図に置き換える
'------------------------------------------------
iMax = myDoc.InlineShapes.Count
For i = 1 To iMax
Set myRange = ActiveDocument.Range(0, 0)
With myRange.Find
.ClearFormatting
.Text = "【★☆★図" & i & "★☆★】"
.Font.Hidden = False
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWholeWord = False
.MatchWildcards = False
If .Execute = True Then
myRange.FormattedText = myDoc.InlineShapes(i).Range.FormattedText
Else
myErr = myErr & vbCr & "図" & i & "が見つかりませんでした。"
DoEvents
End If
End With
Next i
Set myRange = Nothing
myDoc.Close wdDoNotSaveChanges
DoEvents
MsgBox iMax & "個の図を置き換えました。" & vbCr & myErr
End Sub
▼関連記事
【Wordマクロ】行内図をマーカーに置き換える
【Wordマクロ】既存の文書から新規作成する