vba 批量重新设置 word 中的异常图片（2）
Sub test1()
Dim doc As Word.Document
Set doc = ActiveDocument
Dim ish As inlineShape
Dim str As String
' Debug.Print "InlineShapes.Count = "; doc.InlineShapes.Count
For i = doc.InlineShapes.Count To 1 Step -1
Set ish = doc.InlineShapes.Item(i)
If Not ish.LinkFormat Is Nothing Then
str = doc.InlineShapes.Item(i).Range.WordOpenXML
str = GetInlineShapeName(ish)
Debug.Print "Name存在", i, ish.LinkFormat.SourceFullName, str
Else
Debug.Print "AlternativeText", i, ish.AlternativeText
End If
Next
' Update and embed the first inline image using a new file
'Call ReplaceInlineShapeImageAt(doc, 1, "D:\OfficeSpace\ID_E37F9BFD10BF42BDBB2A4A02668F8750.png")
End Sub
Private Function ReplaceInlineShapeAtRange(iShape As InlineShape, imgPath As String, Optional keepSize As Boolean = True, Optional linkToFile As Boolean = True) As Boolean
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
' 高度按比例由 Word 调整，或者也可强制：newIsh.Height = h
End If
ReplaceInlineShapeAtRange = True
Else
ReplaceInlineShapeAtRange = False
End If
End Function
Function ExtractNameFromXML(inlineShape As inlineShape) As String
'从XML中提取ID（高级方法）
Dim xmlName As String
Dim xmlDoc As Object
Dim xmlnode As Object
On Error Resume Next
'尝试访问XML属性
'这需要根据具体的XML结构来调整
xmlName = ""
'创建DOMDocument对象
Set xmlDoc = CreateObject("MSXML2.DOMDocument.6.0")
'加载XML内容
xmlDoc.LoadXML inlineShape.Range.WordOpenXML
'检查是否成功加载XML
If Not xmlDoc Is Nothing And xmlDoc.parseError.ErrorCode = 0 Then
'retrieve Name from wp:docPr or pic:Cnvpr
Set xmlnode = xmlDoc.SelectSingleNode("//wp:docPr")
Set xmlnode = xmlDoc.SelectSingleNode("//*[local-name()='docPr' or local-name()='cNvPr']/@name")
'如果找到节点，则提取其文本内容
If Not xmlnode Is Nothing Then
'xmlName = xmlnode.getAttribute("name")
xmlName = xmlnode.Text
End If
End If
On Error GoTo 0
ExtractNameFromXML = xmlName
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 = GetNameFromXmlMSXML(xml)
If nameVal <> "" Then
GetInlineShapeName = nameVal
Exit Function
End If
' 如果直接片段中没有，尝试扩大范围（前后各+1个字符）
Dim doc As Document, s As Long, e As Long
Set doc = iShape.Parent
s = IIf(iShape.Range.Start - 1 < doc.Content.Start, doc.Content.Start, iShape.Range.Start - 1)
e = IIf(iShape.Range.End + 1 > doc.Content.End, doc.Content.End, iShape.Range.End + 1)
xml = doc.Range(s, e).WordOpenXML
nameVal = GetNameFromXmlMSXML(xml)
If nameVal <> "" Then
GetInlineShapeName = nameVal
Exit Function
End If
' 继续扩大范围到所在段落
xml = iShape.Range.Paragraphs(1).Range.WordOpenXML
nameVal = GetNameFromXmlMSXML(xml)
If nameVal <> "" Then
GetInlineShapeName = nameVal
Exit Function
End If
GetInlineShapeName = ""
End Function
Private Function GetNameFromXmlMSXML(xml As String) As String
On Error Resume Next
Dim s As String: s = xml
Dim dom As Object: Set dom = CreateObject("MSXML2.DOMDocument.6.0")
dom.async = False: dom.validateOnParse = False
If dom.LoadXML(s) Then
Dim node As Object
Set node = dom.SelectSingleNode("//*[local-name()='docPr' or local-name()='cNvPr']/@name")
If Not node Is Nothing Then GetNameFromXmlMSXML = node.Text
End If
End Function
Private Function CsvEscape(ByVal v As Variant) As String
Dim s As String: s = CStr(v)
If InStr(s, """") Or InStr(s, ",") Or InStr(s, vbCr) Or InStr(s, vbLf) Then
s = Replace(s, """", """""")
CsvEscape = """" & s & """"
Else: CsvEscape = s
End If
End Function
' 组装一行 CSV（可变参数）
Private Function CsvJoin(ParamArray arr()) As String
Dim i As Long, parts() As String
ReDim parts(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
parts(i) = CsvEscape(arr(i))
Next
CsvJoin = Join(parts, ",")
End Function
' 写入头部（仅首次创建文件时）
Private Sub CsvMaybeWriteHeader(ByVal fnum As Integer, ByVal filePath As String)
If LOF(fnum) = 0 Then
Print #fnum, CsvJoin("Status", "Index", "SourceFullName", "Name")
End If
End Sub
'
Sub ExportToCsv()
Dim doc As Document: Set doc = ActiveDocument
Dim csvPath As String: csvPath = "c:\officespace\images_report.csv"
Dim f As Integer: f = FreeFile
Open csvPath For Append As #f
CsvMaybeWriteHeader f, csvPath
Dim i As Long
Dim ish As inlineShape
Dim linkPath As String
Dim nameStr As String ' 你的 str 变量（名称）
For i = 1 To doc.InlineShapes.Count
Set ish = doc.InlineShapes(i)
' 安全取 LinkFormat.SourceFullName（可能不是链接图）
linkPath = ""
On Error Resume Next
If Not ish.LinkFormat Is Nothing Then
linkPath = ish.LinkFormat.SourceFullName
On Error GoTo 0
' nameStr = ... 这里生成你的名称（你之前的 str）
' 示例：nameStr = GetInlineShapeName(ish)
' 写入一行
nameStr = GetInlineShapeName(ish)
Print #f, CsvJoin("Name存在", i, linkPath, nameStr)
Else
Print #f, CsvJoin("alt", i, ish.AlternativeText)
End If
Next
Close #f
MsgBox "已写入: " & csvPath
End Sub
'UTF-8 版（若你需要 UTF-8 编码）
' Excel 新版对 UTF-8 支持更好，但用 Open 方式不能写 UTF-8。可用 ADODB.Stream。
' 下面示例会读入已有文件内容，追加一行，再以 UTF-8 保存。
Sub AppendCsvUtf8(filePath As String, lineToAppend As String, Optional writeHeader As Boolean = False, Optional headerLine As String = "")
Dim stm As Object, existing As Object, textAll As String
Set stm = CreateObject("ADODB.Stream")
stm.Type = 2
stm.Charset = "utf-8"
stm.Open
If Dir$(filePath) <> "" Then
Set existing = CreateObject("ADODB.Stream")
existing.Type = 2
existing.Charset = "utf-8"
existing.Open
existing.LoadFromFile filePath
textAll = existing.ReadText(-1)
existing.Close
If Len(textAll) > 0 And Right$(textAll, 2) <> vbCrLf Then textAll = textAll & vbCrLf
stm.WriteText textAll, 0
ElseIf writeHeader And Len(headerLine) > 0 Then
stm.WriteText headerLine & vbCrLf, 0
End If
stm.WriteText lineToAppend & vbCrLf, 0
stm.SaveToFile filePath, 2 'adSaveCreateOverWrite
stm.Close
End Sub
Private Function PickListFile(Optional ByVal title As String = "请选择包含图片路径的 TXT/CSV 文件") As String
On Error Resume Next
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.title = title
.Filters.Clear
.Filters.Add "Text/CSV", "*.txt;*.csv", 1
.AllowMultiSelect = False
If .Show = -1 Then
PickListFile = .SelectedItems(1)
Else
PickListFile = ""
End If
End With
End Function
' 从一行中解析出路径（最简逻辑：支持逗号分隔和双引号包裹）
Private Function ParsePathFromLine(ByVal line As String) As String
Dim s As String: s = Trim$(line)
If s = "" Then Exit Function
If Left$(s, 1) = "'" Or Left$(s, 1) = "#" Then Exit Function ' 注释行
' 若以双引号开头，取下一对双引号之间的内容
If Left$(s, 1) = """" Then
Dim p As Long
p = InStr(2, s, """")
If p > 0 Then
ParsePathFromLine = Mid$(s, 2, p - 2)
Exit Function
End If
End If
' 否则，若含逗号，取首列（CSV 简单场景）
Dim c As Long: c = InStr(1, s, ",")
If c > 0 Then
ParsePathFromLine = Trim$(Left$(s, c - 1))
Else
ParsePathFromLine = s
End If
End Function
' 顺序映射：第1行->第1个 InlineShape, 第2行->第2个...
Public Sub UpdateInlineShapesFromListSequential()
Dim listPath As String: listPath = PickListFile()
If listPath = "" Then Exit Sub
Dim doc As Document: Set doc = ActiveDocument
Dim f As Integer: f = FreeFile
On Error GoTo ErrOpen
Open listPath For Input As #f
Dim i As Long: i = 1
Dim replaced As Long, skipped As Long
Dim raw As String, pathText As String
Do While Not EOF(f) And i <= doc.InlineShapes.Count
Line Input #f, raw
pathText = ParsePathFromLine(raw)
If pathText <> "" And Dir$(pathText) <> "" Then
On Error Resume Next
ReplaceInlineShapeImageAt doc, i, pathText
If Err.Number = 0 Then
replaced = replaced + 1
Else
skipped = skipped + 1
Err.Clear
End If
On Error GoTo 0
Else
skipped = skipped + 1
End If
i = i + 1
Loop
Close #f
MsgBox "顺序更新完成：替换=" & replaced & ", 跳过=" & skipped, vbInformation
Exit Sub
ErrOpen:
MsgBox "无法打开列表文件：" & listPath, vbExclamation
On Error Resume Next
Close #f
End Sub
'按索引更新并嵌入图片
Public Sub ReplaceInlineShapeImageAt(doc As Document, ByVal index As Long, ByVal newPath As String)
Debug.Print "start " & index & vbTab & newPath
Dim ils As inlineShape
If doc Is Nothing Then Exit Sub
If index < 1 Or index > doc.InlineShapes.Count Then Exit Sub
If Dir$(newPath) = "" Then Exit Sub
Set ils = doc.InlineShapes(index)
On Error GoTo Fallback
' 若当前是链接图片，优先走 LinkFormat 流程：更新 -> 嵌入 -> 断开链接
If Not ils.LinkFormat Is Nothing Then
With ils.LinkFormat
.SourceFullName = newPath
.SavePictureWithDocument = True
.Update
.BreakLink
End With
Exit Sub
End If
Fallback:
On Error Resume Next
' 否则直接在原位替换并嵌入（保持尺寸，linkToFile:=False 表示嵌入）
Debug.Print "something is wrong" & vbTab & index & vbTab & newPath
'Call ReplaceInlineShapeAtRange(ils, newPath, True, False)
End Sub
' =============== 高效按基名匹配更新（建立索引，近似 O(N)） ===============
Private Sub DictAddIndex(ByVal dict As Object, ByVal key As String, ByVal idx As Long)
If Len(key) = 0 Then Exit Sub
If Not dict.Exists(key) Then
Dim c As Object: Set c = CreateObject("System.Collections.ArrayList")
dict.Add key, c
End If
dict(key).Add idx
End Sub
Private Function ListPopFirstAvailable(ByVal lst As Object, ByVal used As Object) As Long
Dim i As Long
For i = 0 To lst.Count - 1
If Not used.Exists(CStr(lst(i))) Then
ListPopFirstAvailable = CLng(lst(i))
Exit Function
End If
Next
ListPopFirstAvailable = 0
End Function
Private Sub BuildInlineShapeIndices(ByVal doc As Document, ByRef altIndex As Object, ByRef linkIndex As Object, ByRef xmlNameIndex As Object)
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Set altIndex = CreateObject("Scripting.Dictionary")
Set linkIndex = CreateObject("Scripting.Dictionary")
Set xmlNameIndex = CreateObject("Scripting.Dictionary")
Dim i As Long, ish As inlineShape
Dim alt As String, linkPath As String, baseName As String, xmlName As String
For i = 1 To doc.InlineShapes.Count
Set ish = doc.InlineShapes(i)
On Error Resume Next
alt = ish.AlternativeText
On Error GoTo 0
If Len(alt) > 0 Then DictAddIndex altIndex, alt, i
linkPath = ""
On Error Resume Next
If Not ish.LinkFormat Is Nothing Then linkPath = ish.LinkFormat.SourceFullName
On Error GoTo 0
If Len(linkPath) > 0 Then
baseName = fso.GetBaseName(linkPath)
DictAddIndex linkIndex, baseName, i
End If
xmlName = GetInlineShapeName(ish)
If Len(xmlName) > 0 Then DictAddIndex xmlNameIndex, xmlName, i
Next i
End Sub
Private Sub BuildNameIndexInRange(ByVal doc As Document, ByVal startIdx As Long, ByVal endIdx As Long, ByVal reverse As Boolean, ByRef nameIndex As Object, Optional ByVal preferLink As Boolean = True)
Dim i As Long, idx As Long
Dim nm As String
Set nameIndex = CreateObject("Scripting.Dictionary")
On Error Resume Next
nameIndex.CompareMode = vbTextCompare ' 基于名称的键，忽略大小写
On Error GoTo 0
If reverse Then
For i = endIdx To startIdx Step -1
idx = i
nm = ""
' 预先缓存 LinkFormat 与相关属性
Dim lf As Object
Dim sourceName As String, sourceFull As String
On Error Resume Next
Set lf = doc.InlineShapes(idx).LinkFormat
If Not lf Is Nothing Then
sourceName = lf.sourceName
sourceFull = lf.SourceFullName
End If
On Error GoTo 0
' 仅当需要修复时才建立索引：
' 1) LinkFormat 存在且 SourceName 为空
' 2) 或者 SourceFullName 指向的文件不存在
If Not lf Is Nothing Then
If Len(Trim$(sourceName)) = 0 _
Or (Len(sourceFull) > 0 And Dir$(sourceFull) = "") Then
If preferLink And Len(sourceFull) > 0 Then
Dim fsoR As Object: Set fsoR = CreateObject("Scripting.FileSystemObject")
nm = Trim$(fsoR.GetBaseName(sourceFull))
Else
nm = Trim$(GetInlineShapeName(doc.InlineShapes(idx)))
End If
End If
End If
If Len(nm) > 0 Then
If Not nameIndex.Exists(nm) Then
Dim lst As Object: Set lst = CreateObject("System.Collections.ArrayList")
nameIndex.Add nm, lst
End If
nameIndex(nm).Add idx
End If
Next i
Else
For i = startIdx To endIdx
idx = i
nm = ""
' 预先缓存 LinkFormat 与相关属性
Dim lf2 As Object
Dim sourceName2 As String, sourceFull2 As String
On Error Resume Next
Set lf2 = doc.InlineShapes(idx).LinkFormat
If Not lf2 Is Nothing Then
sourceName2 = lf2.sourceName
sourceFull2 = lf2.SourceFullName
End If
On Error GoTo 0
' 仅当需要修复时才建立索引
If Not lf2 Is Nothing Then
If Len(Trim$(sourceName2)) = 0 _
Or (Len(sourceFull2) > 0 And Dir$(sourceFull2) = "") Then
If preferLink And Len(sourceFull2) > 0 Then
Dim fsoR2 As Object: Set fsoR2 = CreateObject("Scripting.FileSystemObject")
nm = Trim$(fsoR2.GetBaseName(sourceFull2))
Else
nm = Trim$(GetInlineShapeName(doc.InlineShapes(idx)))
End If
End If
End If
If Len(nm) > 0 Then
If Not nameIndex.Exists(nm) Then
Dim lst2 As Object: Set lst2 = CreateObject("System.Collections.ArrayList")
nameIndex.Add nm, lst2
End If
nameIndex(nm).Add idx
End If
Next i
End If
End Sub
Private Function PopFirstUnusedAndRemove(ByVal lst As Object, ByVal used As Object) As Long
Dim k As Long, idx As Long
For k = 0 To lst.Count - 1
idx = CLng(lst(k))
If Not used.Exists(CStr(idx)) Then
PopFirstUnusedAndRemove = idx
lst.RemoveAt k
Exit Function
End If
Next k
PopFirstUnusedAndRemove = 0
End Function
Public Sub UpdateInlineShapesFromListByName_RangeIndex()
Dim doc As Document: Set doc = ActiveDocument
Dim startIdx As Long, endIdx As Long, reverse As Boolean
' 固定范围：1..inlineshapes.count 倒序
startIdx = 1: endIdx = doc.InlineShapes.Count: reverse = True
Dim listPath As String: listPath = PickListFile("请选择包含图片路径的 TXT/CSV（范围小索引：按 OpenXML 名称）")
If listPath = "" Then Exit Sub
' 1) 在范围内建立 name -> [indices] 小索引（调用 GetInlineShapeName，一次性各算一遍）
Dim nameIndex As Object
BuildNameIndexInRange doc, startIdx, endIdx, reverse, nameIndex
' 2) 顺序读取列表，按基名查索引并弹出一个可用下标
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim used As Object: Set used = CreateObject("Scripting.Dictionary")
Dim f As Integer: f = FreeFile
On Error GoTo ErrOpen
Open listPath For Input As #f
Dim raw As String, pathText As String, baseName As String
Dim idx As Long
Dim replaced As Long, skipped As Long
Do While Not EOF(f)
Line Input #f, raw
pathText = ParsePathFromLine(raw)
If pathText = "" Or Dir$(pathText) = "" Then
skipped = skipped + 1
Else
baseName = fso.GetBaseName(pathText)
If nameIndex.Exists(baseName) Then
Do
idx = PopFirstUnusedAndRemove(nameIndex(baseName), used)
If idx <= 0 Then Exit Do
ReplaceInlineShapeImageAt doc, idx, pathText
used.Add CStr(idx), True
replaced = replaced + 1
Loop
Else
skipped = skipped + 1
End If
End If
Loop
Close #f
MsgBox "按 OpenXML 名称（范围索引）更新完成：替换=" & replaced & ", 跳过=" & skipped, vbInformation
Exit Sub
ErrOpen:
MsgBox "无法打开列表文件：" & listPath, vbExclamation
On Error Resume Next
Close #f
End Sub
对存在链接，但链接丢失，且图片异常的图片按照文本中的地址进行替换。
Public Sub UpdateInlineShapesFromListByName_Fast()
Dim listPath As String: listPath = PickListFile("请选择包含图片路径的 TXT/CSV（按基名匹配-快速）")
If listPath = "" Then Exit Sub
Dim doc As Document: Set doc = ActiveDocument
Dim altIndex As Object, linkIndex As Object, xmlNameIndex As Object
BuildInlineShapeIndices doc, altIndex, linkIndex, xmlNameIndex
Dim used As Object: Set used = CreateObject("Scripting.Dictionary")
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim f As Integer: f = FreeFile
On Error GoTo ErrOpen
Open listPath For Input As #f
Dim raw As String, pathText As String, baseName As String
Dim idx As Long
Dim replaced As Long, skipped As Long
Do While Not EOF(f)
Line Input #f, raw
pathText = ParsePathFromLine(raw)
If pathText = "" Or Dir$(pathText) = "" Then
skipped = skipped + 1
Else
baseName = fso.GetBaseName(pathText)
idx = 0
If altIndex.Exists(baseName) Then idx = ListPopFirstAvailable(altIndex(baseName), used)
If idx = 0 And linkIndex.Exists(baseName) Then idx = ListPopFirstAvailable(linkIndex(baseName), used)
If idx = 0 And xmlNameIndex.Exists(baseName) Then idx = ListPopFirstAvailable(xmlNameIndex(baseName), used)
If idx > 0 Then
ReplaceInlineShapeImageAt doc, idx, pathText
used.Add CStr(idx), True
replaced = replaced + 1
Else
skipped = skipped + 1
End If
End If
Loop
Close #f
MsgBox "按基名匹配更新完成（快速）：替换=" & replaced & ", 跳过=" & skipped, vbInformation
Exit Sub
ErrOpen:
MsgBox "无法打开列表文件：" & listPath, vbExclamation
On Error Resume Next
Close #f
End Sub
' 按基名匹配：行路径的文件基名与图片的 AlternativeText 或选择窗格name相同则更新
Public Sub UpdateInlineShapesFromListByName()
Dim listPath As String: listPath = PickListFile("请选择包含图片路径的 TXT/CSV（按基名匹配）")
If listPath = "" Then Exit Sub
Dim doc As Document: Set doc = ActiveDocument
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim used As Object: Set used = CreateObject("Scripting.Dictionary") ' 记录已更新的下标
Dim f As Integer: f = FreeFile
On Error GoTo ErrOpen
Open listPath For Input As #f
Dim raw As String, pathText As String, baseName As String
Dim i As Long, found As Boolean, linkPath As String, alt As String
Dim replaced As Long, skipped As Long
Do While Not EOF(f)
Line Input #f, raw
pathText = ParsePathFromLine(raw)
If pathText = "" Or Dir$(pathText) = "" Then
skipped = skipped + 1
Else
baseName = fso.GetBaseName(pathText)
found = False
'For i = 1 To doc.InlineShapes.Count
For i = 5 To 4 Step -1
If Not used.Exists(CStr(i)) Then
' 先比对 AlternativeText
alt = ""
On Error Resume Next
alt = doc.InlineShapes(i).AlternativeText
On Error GoTo 0
If StrComp(alt, baseName, vbTextCompare) = 0 Then
ReplaceInlineShapeImageAt doc, i, pathText
used.Add CStr(i), True
replaced = replaced + 1
found = True
Exit For
End If
'对比 inlineShape 的 name
On Error Resume Next
If Not doc.InlineShapes(i).LinkFormat Is Nothing Then
picname = GetInlineShapeName(doc.InlineShapes(i))
If StrComp(baseName, picname, vbTextCompare) = 0 Then
ReplaceInlineShapeImageAt doc, i, pathText
Debug.Print i, picname
used.Add CStr(i), True
replaced = replaced + 1
found = True
Exit For
End If
End If
End If
Next i
If Not found Then skipped = skipped + 1
End If
Loop
Close #f
MsgBox "按基名匹配更新完成：替换=" & replaced & ", 跳过=" & skipped, vbInformation
Exit Sub
ErrOpen:
MsgBox "无法打开列表文件：" & listPath, vbExclamation
On Error Resume Next
Close #f
End Sub
浙公网安备 33010602011771号