向word中批量导入图片，并添加题注-2

1. 背景
由于第一版的程序导入时间随着图片量的增加而增加，当图片量达到400多张时，有难难以忍受，因此决定再寻找其他方法。
2. 思路
第一步：将图片和图片名一次性批量粘贴到word中，图片名放在每张图片的下面，并为每个图片名加上前缀“图 XXXX”；
第二步：将文字“XXXX”统一替换成域代码“图 SEQ *ARABIC”.

点击查看代码

Sub 批量插入图片()
    Dim myfile As FileDialog
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    findText = "图 xxxx"
    replaceWith = "DATE"
    With myfile
        .InitialFileName = "E:\WPS图片批量处理\ ' 请将此处替换为你的图片文件夹路径"
        .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磅
                ' 如果需要保持图片纵横比，可以注释掉上一行，并使用以下两行代码：
                ' OriginalWidth = MyPic.Width
                ' MyPic.LockAspectRatio = msoFalse
                ' MyPic.Width = 15 * 28.35
                ' MyPic.Height = (MyPic.Height / OriginalWidth) * (15 * 28.35)
                Selection.TypeParagraph ' 在图片后添加段落
                strFileName_raw = Mid(Fn, InStrRev(Fn, "\") + 1)
                prefix_pos = InStr(1, strFileName_raw, "_")
                strFileName = " " + Mid(strFileName_raw, prefix_pos + 1, InStrRev(strFileName_raw, ".", Compare:=1) - (prefix_pos + 1))
                Selection.Text = findText & strFileName  '添加题注文字
                Selection.Start = Selection.Range.End
                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 rngSearch As Range

    Set oDoc = ActiveDocument
    Set rngSearch = oDoc.Range
    findText = "xxxx"
    replaceWith = "DATE"
    With rngSearch.Find
        .Text = findText ' 要查找的文本
        .Forward = True
        .Wrap = wdFindStop
        Do While .Execute
            With rngSearch
                .Text = "" ' 清除原有文本
                .Fields.Add Range:=.Duplicate, Type:=wdFieldEmpty, Text:="SEQ 图 \* ARABIC", PreserveFormatting:=False
            End With
            rngSearch.Collapse wdCollapseEnd
        Loop
    End With

End Sub

**3. 效果** 相对于版本1，导入和修改速度得到大幅提升。