カーソル位置にインライン画像を挿入するマクロ（Word）

カーソル位置にインライン画像を挿入するマクロ

もちろん、ただ単にインライン画像を挿入するだけではありません。

仕様

• ダイアログボックスで画像を選択する。
• カーソル位置に挿入する。
• 画像用のスタイルを当てる
• 四方に枠線を施す
• 図表番号を付ける

実にこれだけのことが1クリックでできます。

ソースコード

リスト１

Option Explicit

'ファイルフィルタ用文字列'
Private Const FILE_FILTER_TYPE As String = "すべての図"
Private Const FILE_FILTER_EXTENTION As String = "*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.gif;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.eps;*.pct;*.pict;*.wpg"

Private m_FSO As Object

'エントリポイント'
Public Sub InsertInlineShapeWithSettings()
  If Not InsertInlineShape(Selection.Range) Then Exit Sub
  Call ApplyInlineShapeSettingsMain
End Sub

'///インライン画像の四方を囲む'
Private Sub SetBordersAround(ByVal a_InlineShape As InlineShape, _
                    Optional ByVal a_LineStyle As MsoLineStyle _
                                              = msoLineSingle, _
                    Optional ByVal a_LineWeight As Single = 1#)
  Dim tgtLnFormat As LineFormat
  Set tgtLnFormat = a_InlineShape.Line
  With tgtLnFormat
    .Visible = msoTrue
    .Style = a_LineStyle
    .Weight = a_LineWeight
  End With
End Sub

'インライン画像を挿入する'
Private Function InsertInlineShape( _
                  ByVal a_Range As Range) As Boolean
  InsertInlineShape = False
  'ファイル名の取得。'
  Dim tgtFilePath As String
  tgtFilePath = getInlineShapeFilePath
  'ファイル名が取得出来なかったらFalse'
  If tgtFilePath = "" Then Exit Function
  Dim ilShp As InlineShape
  Set ilShp = a_Range.InlineShapes.AddPicture(tgtFilePath)
  ilShp.LockAspectRatio = msoTrue
  Call ilShp.Select
  InsertInlineShape = True
End Function

'画像を一つだけ選ばせ、ファイル名を取得する'
Private Function getInlineShapeFilePath() As String
  Dim ret As String
  ret = ""
  Dim exDir As String
  If Not HasDocumentProperty("ExDirectory") Then
    Call AddDocumentProperty(a_PropName:="ExDirectory", _
                             a_PropType:=msoPropertyTypeString, _
                             a_DefaultValue:=ThisDocument.Path)
  End If
  If m_FSO Is Nothing Then Set m_FSO = CreateObject("Scripting.FileSystemObject")
  If Not m_FSO.FolderExists(exDir) Then
    exDir = ActiveDocument.Path
  End If
  exDir = ThisDocument.CustomDocumentProperties("ExDirectory").Value
  Dim fpDialog As FileDialog
  Set fpDialog = Application.FileDialog(msoFileDialogFilePicker)
  Dim hasSelected As Boolean
  With fpDialog
    'ダイアログボックスのタイトルを設定'
    .Title = "画像を選択せよ"
    '複数選択の設定'
    .AllowMultiSelect = False
    'デフォルト表示フォルダの設定'
    .InitialFileName = exDir
    '一旦ファイルフィルタをクリア'
    Call .Filters.Clear
    'ファイルフィルタを作成'
    Call .Filters.Add(FILE_FILTER_TYPE, FILE_FILTER_EXTENTION)
    'ボックスを表示して、選択が為されたかどうかを取得'
    hasSelected = .Show
    'ファイル選択されていたら、ファイル名を取得'
    If hasSelected Then
      ret = .SelectedItems(1)
      '一つ目のファイルパスからフォルダパスを取得する'
      exDir = Left(ret, InStrRev(ret, "\")) '"
      '自作ドキュメントプロパティに、選択したファイルのあるフォルダのディレク'
      'トリを書き込む'
      ThisDocument.CustomDocumentProperties("ExDirectory").Value = exDir
    End If
    '再度ファイルフィルタをクリア'
    Call .Filters.Clear
  End With
  '値の返却'
  getInlineShapeFilePath = ret
End Function

'新しい自作ドキュメントプロパティを追加する '
Private Function AddDocumentProperty( _
             ByVal a_PropName As String, _
             ByVal a_PropType As MsoDocProperties, _
             ByVal a_DefaultValue As Variant) As Boolean
  AddDocumentProperty = True
  On Error GoTo HandleError
  'すでに存在するドキュメントプロパティ名を使用すると、Falseを返す'
  'つまり、上書きはしない。'
  Call ThisDocument.CustomDocumentProperties.Add(Name:=a_PropName, _
                                                 LinkToContent:=False, _
                                                 Type:=a_PropType, _
                                                 Value:=a_DefaultValue)
  Exit Function
HandleError:
  AddDocumentProperty = False
End Function

'/// 自作ドキュメントプロパティを削除する '
Private Function DeleteDocumentProperty( _
            ByVal a_PropName As String) As Boolean
  DeleteDocumentProperty = True
  On Error GoTo HandleError
  Call ThisDocument.CustomDocumentProperties.Item(a_PropName).Delete
  Exit Function
HandleError:
  DeleteDocumentProperty = False
End Function

'指定した名前のドキュメントプロパティがあるかどうか'
Private Function HasDocumentProperty( _
            ByVal a_PropName As String) As Boolean
  HasDocumentProperty = True
  Dim cdp As DocumentProperty
  For Each cdp In ThisDocument.CustomDocumentProperties
    If cdp.Name = a_PropName Then Exit Function
  Next
  HasDocumentProperty = False
End Function

'選択中の画像に枠線を施す'
Private Sub setBordersForFigure( _
        Optional ByVal a_LineStyle As MsoLineStyle = msoLineSingle, _
        Optional ByVal a_LineWeight As Single = 1#)
  Dim ilShp As InlineShape
  If Selection.Type = wdSelectionInlineShape Then
    If Selection.InlineShapes.Count = 0 Then Exit Sub
    Set ilShp = Selection.InlineShapes(1)
  Else
    Exit Sub
  End If
  Dim tgtLnFormat As LineFormat
  Set tgtLnFormat = ilShp.Line
  With tgtLnFormat
    .Visible = msoTrue
    .Style = a_LineStyle
    .Weight = a_LineWeight
  End With
End Sub

'ドキュメントが、指定した名前のスタイルを持っているか判定する'
Private Function HasStyle( _
            ByVal a_Document As Document, _
            ByVal a_StyleName As String) As Boolean
  HasStyle = True
  Dim st As Style
  For Each st In a_Document.Styles
    If st.NameLocal = a_StyleName Then Exit Function
  Next
  HasStyle = False
End Function

Private Sub CreateStyleForFigure1(ByVal a_Document As Document)
'///「Cst図1」スタイルを作成するためだけのメソッド ///'
  Dim st As Style
  Set st = a_Document.Styles.Add("Cst図1")
  With st
    .Visibility = True
    .UnhideWhenUsed = True
    .QuickStyle = True
    .Priority = 1
    .BaseStyle = "標準"
    .NextParagraphStyle = "図表番号"
    With .ParagraphFormat
      .Alignment = wdAlignParagraphCenter
      .LineUnitBefore = 0.5
    End With
  End With
End Sub

'選択中の画像にスタイルを当てて枠線を施し、キャプションも付ける'
Private Sub ApplyInlineShapeSettingsMain()
  Const STYLE_FOR_FIGURE_1 As String = "Cst図1"
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim ilShp As InlineShape
  If Selection.Type = wdSelectionInlineShape Then
    Set ilShp = Selection.InlineShapes(1)
  Else
    Exit Sub
  End If
  '`Cst図1`スタイルがなかったら作る。'
  If Not HasStyle(tgtDoc, STYLE_FOR_FIGURE_1) Then
    Call CreateStyleForFigure1(tgtDoc)
  End If
  Call applyInlineShapeSettings(STYLE_FOR_FIGURE_1, "図")
End Sub

'インライン画像に枠線・スタイル・図表番号をセットする'
Private Sub applyInlineShapeSettings( _
            ByVal a_ParagraphStyleName As String, _
            Optional ByVal a_LabelName As String, _
            Optional ByVal a_CaptionPosition As WdCaptionPosition _
                                        = wdCaptionPositionBelow, _
            Optional ByVal a_LineStyle As MsoLineStyle _
                                          = msoLineSingle, _
            Optional ByVal a_LineWeight As Single = 1#)
'### 行内の画像に段落スタイルと枠線と図表番号をセットする         ###'
'### 引数 a_ParagraphStyleName：段落スタイルの名前                ###'
'### 引数 a_LabelName：ラベルの名前                               ###'
'### 引数 a_CaptionPosition：図表番号の位置                       ###'
'### 引数 a_LineStyle：枠線の種類                                 ###'
'### 引数 a_LineWeight：枠線の太さ                                ###'

  '画像に枠線をセットする'
  Call setBordersForFigure(msoLineSingle)
  '段落スタイルを適用する'
  Selection.Style = a_ParagraphStyleName
  If a_LabelName = "" Then GoTo ComeHere
  '図表番号のラベルをセットする'
  Dim lblIndex As Long
  lblIndex = getCaptionLabelIndex(a_LabelName)
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  '図表番号を挿入する'
  Call Selection.InsertCaption(Label:=captLabels(lblIndex), _
                               Position:=a_CaptionPosition)
ComeHere:
End Sub

Private Sub SetCaption(Optional ByVal a_LabelName As String = "図", _
                       Optional ByVal a_Position As WdCaptionPosition = wdCaptionPositionBelow)
  '図表番号のラベルをセットする'
  Dim lblIndex As Long
  lblIndex = getCaptionLabelIndex(a_LabelName)
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  '図表番号を挿入する'
  Call Selection.InsertCaption(Label:=captLabels(lblIndex), _
                               Position:=a_Position)

End Sub

'図表番号のインデックスを取得する'
Private Function getCaptionLabelIndex( _
                 ByVal a_TgtLabelName As String) As Long
  '### 受けとったラベル名が CaptionLabelsコレクションの何番目にあ  ###'
  '### るかを返す。コレクション内になかったら、新規追加してその番  ###'
  '### を返す。                                                    ###'
  Dim ret As Long
  Dim captLabels As CaptionLabels
  Set captLabels = Application.CaptionLabels
  Dim i As Long
  For i = 1 To captLabels.Count
    If captLabels(i) = a_TgtLabelName Then
      ret = i
      GoTo ReturnValue
    End If
  Next
  Call captLabels.Add(a_TgtLabelName)
  ret = captLabels.Count
ReturnValue:
  getCaptionLabelIndex = ret
End Function

上記コードをまるごとNormal.dotmの標準モジュールに貼り付けて、InsertInlineShapeWithSettingsをクイック アクセス ツール バーに登録します。

図に当てるスタイルについては、Cst図1という名前で決め打ちにしてあります。（めんどくさいので。）

おわりに

画像を挿入して、枠線を施して、図表番号を入れて……という作業は、地味にめんどくさいので、1クリックで画像選択ダイアログが出てきて、画像を選択（ダブルクリック）したらあとは勝手に枠線、スタイル当て、図表番号挿入までやってくれるので、めんどくさい作業が最短3クリックでできるようになります。

ずいぶん前に作ったマクロなので、もしかしたら動きが変なところがあるかも知れません。テキトーに直して使ってください。