vba 批量重新设置 word 中的异常图片（1）

对 word 文档一些操作后，重新打开发现
无法显示链接的图像。该文件可能已被移动、重命名或删除。请验证该链接是否指向正确的文件和位置。

文件-信息——编辑指向文件的链接，可以看到 源文件不存在

使用 ?selection.inlineshapes(1).AlternativeText 在立即窗口 返回空

好在可以从选择窗格看到一些信息，
下面根据选择窗格看到的图片信息，或者document.xml中的wp:docPr或pic:cNvPr元素的name属性值，替换为某个文件夹下的对应图片。
以下内容主要针对 inlineshape

Option Explicit
'==================== 主入口 ====================
Sub RepairBrokenInlinePictures()
    Dim doc As Document: Set doc = ActiveDocument   'ThisDocument 有时指模板，ActiveDocument 更保险
    Dim i As Long, ish As inlineShape
    Dim nameVal As String, baseName As String, ext As String
    Dim imgPath As String, pickedRoot As String
    Dim fixedCount As Long, skippedCount As Long
    ' 选择根目录
    pickedRoot = PickFolder("请选择本地图片所在的根目录（将按名称递归搜索）：")
    If pickedRoot = "" Then Exit Sub
    Application.ScreenUpdating = False
    Application.StatusBar = "正在检测图片状态，请稍候……"
    For i = doc.InlineShapes.count To 1 Step -1      '倒序，避免索引错位
        Set ish = doc.InlineShapes(i)
        Debug.Print "start "
        ' 跳过非图片对象
        If ish.Type <> wdInlineShapePicture And _
            ish.Type <> wdInlineShapeLinkedPicture And _
            ish.Type <> wdInlineShapeLinkedPictureHorizontalLine Then
            skippedCount = skippedCount + 1
            GoTo ContinueLoop
        End If
 
        ' 判断是否真的损坏
        If Not IsPictureBroken(ish) Then
            skippedCount = skippedCount + 1
            GoTo ContinueLoop
        End If
 
        ' 提取名字
        nameVal = GetInlineShapeName(ish)
        If nameVal <> "" Then
            baseName = nameVal
            ext = ""                    '由搜索函数自动补扩展名
        Else
            ' 一次弹窗让用户输入“文件名.扩展名”，允许带后缀
            baseName = InputBox( _
                "第 " & i & " 张图片无法提取名称，请输入完整文件名（可含扩展名，如  abc.png 或 图片8.jpg）：", _
                "手动输入文件名", "")
            If baseName = "" Then GoTo ContinueLoop        '用户取消
            ' 如果用户给了扩展名，则记录下来
            If InStrRev(baseName, ".") > 0 Then
                ext = Mid$(baseName, InStrRev(baseName, "."))
                baseName = left$(baseName, InStrRev(baseName, ".") - 1)
            Else
                ext = ""
            End If
        End If
 
        ' 搜索文件
        imgPath = ""
        If ext = "" Then
            ' 自动补扩展名
            If Not FindFileByBaseName(pickedRoot, baseName, imgPath) Then
                Debug.Print "  未找到文件：" & baseName
                GoTo ContinueLoop
            End If
        Else
            ' 用户给了扩展名，直接拼
            imgPath = pickedRoot & "\" & baseName & ext
            If Dir(imgPath) = "" Then
                Debug.Print "  未找到文件：" & imgPath
                GoTo ContinueLoop
            End If
        End If
 
        ' 替换
        Dim newIsh As inlineShape
        Set newIsh = ReplaceInlineShapeAtRange(ish, imgPath, True, True)
        If Not newIsh Is Nothing Then
            newIsh.AlternativeText = baseName   ' 用新的对象写
            fixedCount = fixedCount + 1
            Application.StatusBar = "已修复 " & fixedCount & " 张……"
            ' 原位断链：不改变版式
            newIsh.LinkFormat.SavePictureWithDocument = True       ' 保存位图进文档
            newIsh.LinkFormat.AutoUpdate = False
            newIsh.LinkFormat.BreakLink                          ' 断开链接
            DoEvents
        Else
            Debug.Print "  替换失败" & imgPath
        End If
ContinueLoop:
    Next i
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "修复完成！共修复 " & fixedCount & " 张，跳过 " & skippedCount & " 张。", vbInformation
End Sub
 
'==================== 判断图片是否损坏（Word 专用） ====================
Private Function IsPictureBroken(ish As inlineShape) As Boolean
    On Error Resume Next
    '---------------------------------------------
    ' 1. 链接图：检查路径是否为空或文件不存在
    '---------------------------------------------
    If ish.Type = wdInlineShapeLinkedPicture _
        Or ish.Type = wdInlineShapeLinkedPictureHorizontalLine Then
        Dim srcPath As String
        srcPath = ish.LinkFormat.SourceFullName
        IsPictureBroken = (srcPath = "" Or Dir(srcPath) = "")
        Exit Function
    End If
 
    '---------------------------------------------
    ' 2. 嵌入图片：复制到剪贴板，看是否会报错
    '---------------------------------------------
    If ish.Type = wdInlineShapePicture _
        Or ish.Type = wdInlineShapePictureHorizontalLine Then
        ish.Range.CopyAsPicture          '如果图片数据缺失，这里会抛错
        If Err.Number <> 0 Then
            IsPictureBroken = True
            Err.Clear
        Else
            ' 复制成功，说明图片至少还有数据
            IsPictureBroken = False
        End If
        Exit Function
    End If
 
    '---------------------------------------------
    ' 3. 其他类型（图表、OLE 等）视为正常
    '---------------------------------------------
    IsPictureBroken = False
End Function
 
'==================== 提取名称 ====================
Private Function GetInlineShapeName(iShape As inlineShape) As String
    On Error Resume Next
    Dim xml As String, nameVal As String
    xml = iShape.Range.WordOpenXML
    nameVal = GetNameFromXml(xml)
    If nameVal <> "" Then
        GetInlineShapeName = nameVal
        Exit Function
    End If
 
    ' 扩大范围到段落
    xml = iShape.Range.Paragraphs(1).Range.WordOpenXML
    nameVal = GetNameFromXml(xml)
    If nameVal <> "" Then
        GetInlineShapeName = nameVal
        Exit Function
    End If
    GetInlineShapeName = ""
End Function

Private Function GetNameFromXml(ByVal xml As String) As String
    Dim pos As Long, s As Long, e As Long
    ' <wp:docPr name="xxx"
    pos = InStr(1, xml, "<wp:docPr")
    If pos > 0 Then
        pos = InStr(pos, xml, "name=""")
        If pos > 0 Then
            s = pos + 6
            e = InStr(s, xml, """")
            If e > s Then
                GetNameFromXml = Mid$(xml, s, e - s)
                Exit Function
            End If
        End If
    End If
 
    ' <pic:cNvPr name="xxx"
    pos = InStr(1, xml, "<pic:cNvPr")
    If pos > 0 Then
        pos = InStr(pos, xml, "name=""")
        If pos > 0 Then
            s = pos + 6
            e = InStr(s, xml, """")
            If e > s Then
                GetNameFromXml = Mid$(xml, s, e - s)
                Exit Function
            End If
        End If
    End If
End Function
 
'==================== 递归搜索 ====================
Private Function FindFileByBaseName(rootFolder As String, baseName As String, ByRef foundPath As String) As Boolean
    On Error Resume Next
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(rootFolder) Then Exit Function
    Dim extArr As Variant, ext As Variant
    extArr = Array(".png", ".jpg", ".jpeg", ".gif", ".bmp", ".tif", ".tiff", ".webp")
    Dim folder As Object, file As Object, subFolder As Object
    ' 先尝试常见扩展名
    For Each ext In extArr
        Dim testPath As String
        testPath = fso.BuildPath(rootFolder, baseName & ext)
        If fso.FileExists(testPath) Then
            foundPath = testPath
            FindFileByBaseName = True
            Exit Function
        End If
    Next
    ' 遍历子文件夹
    Set folder = fso.GetFolder(rootFolder)
    For Each subFolder In folder.SubFolders
        If FindFileByBaseName(subFolder.Path, baseName, foundPath) Then
            FindFileByBaseName = True
            Exit Function
        End If
    Next
End Function
 
'==================== 替换图片 ====================
' 返回：成功 → 新的 InlineShape；失败 → Nothing
Private Function ReplaceInlineShapeAtRange(iShape As inlineShape, _
        imgPath As String, _
        Optional keepSize As Boolean = True, _
        Optional linkToFile As Boolean = True) As inlineShape
 
    On Error Resume Next
    Dim rng As Range, w As Single, h As Single
    Set rng = iShape.Range
    If keepSize Then
        w = iShape.width
        h = iShape.height
    End If
    iShape.Delete
    Dim newIsh As inlineShape
    Set newIsh = rng.InlineShapes.AddPicture(fileName:=imgPath, _
        linkToFile:=linkToFile, _
        SaveWithDocument:=Not linkToFile)
    If Not newIsh Is Nothing Then
        If keepSize Then
            newIsh.lockAspectRatio = msoTrue
            newIsh.width = w
        End If
    End If
    Set ReplaceInlineShapeAtRange = newIsh   ' 返回新对象
End Function
 
'==================== 选择文件夹 ====================
Private Function PickFolder(prompt As String) As String
    On Error Resume Next
    Dim fd As fileDialog
    Set fd = Application.fileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = prompt
        .AllowMultiSelect = False
        If .Show = -1 Then
            PickFolder = .SelectedItems(1)
        Else
            PickFolder = ""
        End If
    End With
End Function

如果不是很理解，网上看到一篇可以的阅读的文章 VBA编程一例：解决WORD文档无法显示链接的图像问题