向word中批量导入图片，并添加题注-11. 背景处理一次性导入480张图片到word，并将图片的名称添加为题注“图1

1. 背景 处理一次性导入480张图片到word，并将图片的名称添加为题注“图1 ...”，第一次使用手工为每个图片添加题注，太废手了，遂想到用vb写一段程序来解决。 2.主要思路 代码分两部分，第一部分是批量添加图片，然后使用列表按添加顺序存储图片路径；第二部分是循环给每个图片添加题注，由于图片名称是“序号_xxxxx.png”，因此添加题注时需要去除序号和尾缀部分，代码如下。

点击查看代码

Dim caption_array() As String

Sub 批量插入图片()
    Dim myfile As FileDialog
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    With myfile
        .InitialFileName = "E:\图片批量处理\ ' 请将此处替换为你的图片文件夹路径"
        .Filters.Clear
        .Filters.Add "Images", "*.jpg; *.jpeg; *.png; *.bmp; *.gif", 1
        If .Show = -1 Then
            Dim Fn As Variant
            ReDim caption_array(.SelectedItems.Count)
            i = 0
            For Each Fn In .SelectedItems
                'Debug.Print (Fn.LinkFormat.SourceFullName)
                Set MyPic = Selection.InlineShapes.AddPicture(FileName:=Fn, _
                    LinkToFile:=False, SaveWithDocument:=True)
                ' 统一调整图片宽度（例如设置为15厘米）
                MyPic.Width = 15 * 28.35 ' 1厘米等于28.35磅
                Selection.TypeParagraph ' 在图片后添加段落
                caption_array(i) = Fn
                i = i + 1
            Next Fn
        End If
    End With
    Set myfile = Nothing
End Sub

Sub 为图片添加题注()
    Dim oDoc As Document
    Dim oPic As InlineShape
    Dim strCaptionLabel As String
    Dim strFileName_raw As String
    Dim strFileName As String
    Dim prefix_pos As Integer


    Application.ScreenUpdating = False

    Set oDoc = ActiveDocument
    ' 设置不更新域
    ActiveDocument.Fields.Locked = True

    strCaptionLabel = "图"     ' 设置题注标签为“图”
    i = 0
    For Each oPic In oDoc.InlineShapes
        If oPic.Type = wdInlineShapePicture Then
            ' 提取图片文件名（不带路径）
            'strFileName = Mid(oPic.LinkFormat.SourceFullName, _
                'InStrRev(oPic.LinkFormat.SourceFullName, "\") + 1)
            strFileName_raw = Mid(caption_array(i), InStrRev(caption_array(i), "\") + 1)
            prefix_pos = InStr(1, strFileName_raw, "_")
            strFileName = " " + Mid(strFileName_raw, prefix_pos + 1, InStrRev(strFileName_raw, ".", Compare:=1) - (prefix_pos + 1))
            'strFileName = " " + Split(strFileName_raw, ".")(0)
            i = i + 1
            ' 为图片添加题注
            oPic.Select
            Selection.InsertCaption Label:=strCaptionLabel, _
                Position:=wdCaptionPositionBelow, _
                ExcludeLabel:=False, _
                TitleAutoText:="", _
                Title:=strFileName
        End If
    Next oPic
    oDoc.Fields.Locked = False
    oDoc.Fields.Update
    Application.ScreenUpdating = True
    Erase caption_array
    Set oDoc = Nothing
End Sub

**3. 存在问题** 代码可以正常运行，但由于每给一张图片添加题注，word就会去更新域，当图片数量太多时，越到后面运行速度越慢，如果有大量图片需要导入时，建议将图片拆分一下，分多次导入到多个word文档再合并。