VBA 批量居重设 Excel 中的图片
针对 dispimg 公式引用的嵌入图片或普通图片，创建工作簿副本，解压后，然后再重新粘贴到对应单元格。
与原生 wps 表格的嵌入转浮动相比，位置不完全移至。选择一个图片，按 ctrl+A 全部选择图片，然后删除图片，可以运行 DISPIMG_QuickRenderAllAnchors 宏恢复。
如果想要根据选择窗格的名字进行替换图片，可以将对应的图片放置于某个文件夹下，运行宏，然后选择该文件夹。
' Attribute VB_Name = "modDispImgAnchor"
Option Explicit
' ========================= 概要说明 =========================
' 高级版：按 Excel/WPS DrawingML 锚点(oneCellAnchor/twoCellAnchor)
' 将已导出的图片(按 cNvPr/@name 命名，例如 ID_XXXXXXXX...) 精确定位到工作表。
' - 支持：
' 1) 全部渲染：遍历所有工作表及 drawing*.xml，按锚点定位
' 2) 按公式过滤：仅渲染当前工作表中公式含有 DISPIMG("ID_xxx") 的图片
' - 无需设置引用：全部使用后期绑定(CreateObject)。
' - 需要你事先用工具导出图片到某个目录，文件名形如：ID_XXXXXXXX....png/jpg/...
'
' 使用方法：
' 1) Excel -> 开发工具 -> Visual Basic -> 插入 -> 模块，复制本文件所有内容到新模块中。
' 2) Alt+F8 运行：
' - DISPIMG_QuickRenderAllAnchors 选择图片目录，按锚点渲染全部图片
' - DISPIMG_QuickRenderByFormula 选择图片目录，仅渲染表内引用的 ID
' 3) 也可在工作表事件中调用：Worksheet_Calculate 里调用 DISPIMG_RenderByFormula
'
' 注意：
' - 运行前请先保存工作簿（.xlsx/.xlsm）。
' - 代码会把工作簿复制为临时 zip 后解压，解析 xl\workbook.xml / drawings / rels。
' - 插入的形状名称前缀为 "ANC_"，重复渲染前会自动清理旧的 ANC_ 形状。
' ===========================================================
' Office/Excel 常量（避免额外引用）
Private Const MSO_TRUE As Long = -1
Private Const MSO_FALSE As Long = 0
Private Const XL_MOVE_AND_SIZE As Long = 1
' =============== 对外入口 ===============
' 交互式：选择图片目录，渲染全部锚点
Public Sub DISPIMG_QuickRenderAllAnchors()
Debug.Print "[ENTRY] AllAnchors start", Now
Dim imgFolder As String
imgFolder = PickFolder("请选择图片所在文件夹（取消则仅用内嵌图片）")
Debug.Print "[ENTRY] folder=", imgFolder
If Len(imgFolder) = 0 Then
Debug.Print "[ENTRY] cancelled -> use embedded images"
' proceed with embedded images only
End If
DISPIMG_RenderAllAnchors imgFolder
End Sub
' 交互式：选择图片目录，仅渲染当前工作簿中各表的 DISPIMG 公式引用到的 ID
Public Sub DISPIMG_QuickRenderByFormula()
Dim imgFolder As String
imgFolder = PickFolder("请选择图片所在文件夹（取消则仅用内嵌图片）")
' If no folder chosen, proceed with embedded images only
DISPIMG_RenderByFormula imgFolder
End Sub
' 按锚点渲染所有图片（所有工作表，不管是否有公式）
Public Sub DISPIMG_RenderAllAnchors(ByVal imgFolder As String)
Dim wb As Workbook: Set wb = ActiveWorkbook
If Len(Dir$(wb.FullName)) = 0 Then
MsgBox "请先保存工作簿再运行。", vbExclamation
Exit Sub
End If
Debug.Print "[RBF] wb.FullName=", wb.FullName
Debug.Print "[RBF] wb.FullName=", wb.FullName
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo CLEANUP
Dim tmpRoot As String, unzipDir As String
tmpRoot = CreateTempFolder("")
Debug.Print "[RBF] tmpRoot=", tmpRoot
If Len(tmpRoot) = 0 Then
MsgBox "无法创建临时目录（根）。请检查权限或磁盘空间。", vbExclamation
GoTo CLEANUP
End If
On Error GoTo CLEANUP
unzipDir = CreateTempFolder(tmpRoot)
Debug.Print "[RBF] unzipDir=", unzipDir
If Len(unzipDir) = 0 Then
MsgBox "无法创建临时目录（解压目标）。请检查权限或磁盘空间。", vbExclamation
GoTo CLEANUP
End If
Debug.Print "[RBF] Call Unzip:", wb.FullName, " -> ", unzipDir
If Not UnzipWorkbookToFolder(wb.FullName, unzipDir) Then
Debug.Print "[RBF] Unzip failed for:", wb.FullName, " -> ", unzipDir
MsgBox "解压失败。", vbCritical
GoTo CLEANUP
End If
Dim sheetMap As Object ' Scripting.Dictionary (sheetXml -> sheetName)
Set sheetMap = MapSheetXmlToName(unzipDir)
If sheetMap Is Nothing Or sheetMap.Count = 0 Then GoTo CLEANUP
Dim key As Variant
For Each key In sheetMap.Keys
Dim sheetXml As String: sheetXml = CStr(key)
Dim sheetName As String: sheetName = CStr(sheetMap(key))
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then GoTo NEXT_SHEET
Dim drawingRel As String
drawingRel = FindSheetDrawingTarget(unzipDir, sheetXml)
If Len(drawingRel) = 0 Then GoTo NEXT_SHEET
Dim drawingXml As String
drawingXml = NormalizePath(AddSlash(unzipDir) & "xl\" & Replace(drawingRel, "../", ""))
If Len(Dir$(drawingXml)) = 0 Then GoTo NEXT_SHEET
DeleteShapesByPrefix ws, "ANC_"
RenderDrawingAnchorsToSheet ws, drawingXml, imgFolder, Nothing
' Also render Excel 365 cell images (cellimages.xml)
RenderCellImagesToSheet ws, unzipDir, sheetXml, imgFolder, Nothing
NEXT_SHEET:
Set ws = Nothing
Next
MsgBox "锚点渲染完成。", vbInformation
CLEANUP:
On Error Resume Next
If Len(unzipDir) > 0 Then DeleteFolderSilent unzipDir
If Len(tmpRoot) > 0 Then DeleteFolderSilent tmpRoot
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
' 仅渲染各表中公式里引用到的 ID（DISPIMG("ID_xxx"...)）
Public Sub DISPIMG_RenderByFormula(ByVal imgFolder As String)
Debug.Print "[RBF] Start", Now, " imgFolder=", imgFolder
Dim wb As Workbook: Set wb = ActiveWorkbook
If Len(Dir$(wb.FullName)) = 0 Then
MsgBox "请先保存工作簿再运行。", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo CLEANUP
Dim tmpRoot As String, unzipDir As String
tmpRoot = CreateTempFolder("")
Debug.Print "[RBF] tmpRoot=", tmpRoot
If Len(tmpRoot) = 0 Then
MsgBox "无法创建临时目录（根）。请检查权限或磁盘空间。", vbExclamation
GoTo CLEANUP
End If
unzipDir = CreateTempFolder(tmpRoot)
Debug.Print "[RBF] unzipDir=", unzipDir
If Len(unzipDir) = 0 Then
MsgBox "无法创建临时目录（解压目标）。请检查权限或磁盘空间。", vbExclamation
GoTo CLEANUP
End If
Debug.Print "[RBF] Call Unzip:", wb.FullName, " -> ", unzipDir
If Not UnzipWorkbookToFolder(wb.FullName, unzipDir) Then
Debug.Print "[RBF] Unzip failed for:", wb.FullName, " -> ", unzipDir
MsgBox "解压失败。", vbCritical
GoTo CLEANUP
End If
Dim sheetMap As Object ' Scripting.Dictionary
Set sheetMap = MapSheetXmlToName(unzipDir)
If sheetMap Is Nothing Or sheetMap.Count = 0 Then
Debug.Print "[RBF] sheetMap empty"
GoTo CLEANUP
End If
Dim ws As Worksheet
For Each ws In wb.Worksheets
Debug.Print "[RBF] WS:", ws.name
Dim ids As Object ' Scripting.Dictionary
Set ids = CollectDispImgIdsOnSheet(ws)
If ids Is Nothing Then
Debug.Print "[RBF] ids=None"
GoTo NEXT_WS
End If
Debug.Print "[RBF] ids.Count=", ids.Count
If ids.Count > 0 Then
Dim sheetXml As String: sheetXml = FindSheetXmlByName(sheetMap, ws.name)
Debug.Print "[RBF] sheetXml=", sheetXml
If Len(sheetXml) = 0 Then GoTo NEXT_WS
Dim drawingRel As String: drawingRel = FindSheetDrawingTarget(unzipDir, sheetXml)
Debug.Print "[RBF] drawingRel=", drawingRel
If Len(drawingRel) = 0 Then GoTo NEXT_WS
Dim drawingXml As String
drawingXml = NormalizePath(AddSlash(unzipDir) & "xl\" & Replace(drawingRel, "../", ""))
Debug.Print "[RBF] drawingXml=", drawingXml, " exists=", (Len(Dir$(drawingXml)) > 0)
If Len(Dir$(drawingXml)) = 0 Then GoTo NEXT_WS
DeleteShapesByPrefix ws, "ANC_"
Debug.Print "[RBF] Render sheet", ws.name
Dim shapesBefore As Long: shapesBefore = ws.Shapes.Count
RenderDrawingAnchorsToSheet ws, drawingXml, imgFolder, ids
' Also render Excel 365 cell images (cellimages.xml) per formula filter
RenderCellImagesToSheet ws, unzipDir, sheetXml, imgFolder, ids
Dim added As Long: added = ws.Shapes.Count - shapesBefore
Debug.Print "[RBF] anchors rendered diff=", added
If added <= 0 Then
Debug.Print "[RBF] fallback to formula-direct on ws:", ws.name
RenderByFormulaDirect ws, imgFolder
End If
End If
NEXT_WS:
Next
MsgBox "按公式匹配的锚点渲染完成。", vbInformation
CLEANUP:
Debug.Print "[RBF] CLEANUP enter Err.Number=", Err.Number, " Desc=", Err.Description
On Error Resume Next
If Len(unzipDir) > 0 Then DeleteFolderSilent unzipDir
If Len(tmpRoot) > 0 Then DeleteFolderSilent tmpRoot
Application.EnableEvents = True
Application.ScreenUpdating = True
Debug.Print "[RBF] CLEANUP exit"
End Sub
' Helper: Render all anchors using only embedded images (no folder prompt)
Public Sub DISPIMG_QuickRenderAllAnchors_EmbeddedOnly()
Debug.Print "[ENTRY] AllAnchors-EmbeddedOnly start", Now
DISPIMG_RenderAllAnchors vbNullString
End Sub
' Helper: Render by formula using only embedded images (no folder prompt)
Public Sub DISPIMG_QuickRenderByFormula_EmbeddedOnly()
Debug.Print "[ENTRY] ByFormula-EmbeddedOnly start", Now
DISPIMG_RenderByFormula vbNullString
End Sub
' =============== 解析与渲染核心 ===============
' 遍历 drawing*.xml 的 oneCellAnchor / twoCellAnchor，按锚点插入图片
Private Sub RenderDrawingAnchorsToSheet(ByVal ws As Worksheet, ByVal drawingXmlPath As String, ByVal imgFolder As String, ByVal idFilter As Object)
Dim doc As Object ' MSXML2.DOMDocument60
Set doc = CreateObject("MSXML2.DOMDocument.6.0")
doc.async = False: doc.validateOnParse = False
doc.SetProperty "SelectionLanguage", "XPath"
If Not doc.Load(drawingXmlPath) Then Exit Sub
Dim anchors As Object, a As Object
Set anchors = doc.SelectNodes("//*[local-name()='oneCellAnchor' or local-name()='twoCellAnchor']")
On Error Resume Next
Debug.Print "[DRAW] anchors count=", anchors.Length
On Error GoTo 0
Dim idx As Long: idx = 1
For Each a In anchors
Dim picName As String
picName = GetPicName(a)
Debug.Print "[ANCHOR] name=", picName
' 尝试从锚点对应的起始单元格公式中解析 ID（更可靠）
Dim anchorId As String
anchorId = TryGetIdFromAnchor(ws, a)
If Len(anchorId) > 0 Then
Debug.Print "[ANCHOR] id-from-cell=", anchorId
End If
' 选择用于查找图片的键：优先使用公式ID，否则用 cNvPr name
Dim lookupKey As String
If Len(anchorId) > 0 Then
lookupKey = anchorId
Else
lookupKey = picName
End If
If Len(lookupKey) = 0 Then GoTo NEXT_A
' 优先尝试：若提供了 idFilter 但 lookupKey 不在其中，则尝试用内嵌媒体（rels→xl/media）
Dim picPath As String
Dim embeddedPath As String
picPath = vbNullString
embeddedPath = ResolveEmbeddedImageFromAnchor(drawingXmlPath, a)
If Not idFilter Is Nothing Then
If Not idFilter.exists(lookupKey) Then
If Len(embeddedPath) > 0 Then
picPath = embeddedPath
Debug.Print "[ANCHOR] use embedded for non-formula:", lookupKey, " -> ", picPath
Else
Debug.Print "[ANCHOR] skip not in formula:", lookupKey
GoTo NEXT_A
End If
End If
End If
' Choose source: prefer embedded for default "图片 N"/"Picture N" names to avoid wrong external matches
Dim isDefaultName As Boolean
isDefaultName = (InStr(1, lookupKey, "图片 ", vbTextCompare) = 1 Or InStr(1, lookupKey, "Picture ", vbTextCompare) = 1)
If Len(picPath) = 0 Then
If isDefaultName Then
If Len(embeddedPath) > 0 Then
picPath = embeddedPath
Debug.Print "[ANCHOR] prefer embedded for default name:", lookupKey, " -> ", picPath
End If
End If
End If
If Len(picPath) = 0 Then
If Len(imgFolder) > 0 And Not isDefaultName Then
picPath = FindImageById(imgFolder, lookupKey)
ElseIf Len(embeddedPath) > 0 And Len(imgFolder) = 0 Then
picPath = embeddedPath
Debug.Print "[ANCHOR] using embedded (no external folder):", lookupKey, " -> ", picPath
End If
End If
If Len(picPath) = 0 And Len(embeddedPath) > 0 Then
picPath = embeddedPath
End If
If Len(picPath) = 0 Then
Debug.Print "[ANCHOR] image not found for:", lookupKey
GoTo NEXT_A
End If
Debug.Print "[RENDER] picName=", picName
Debug.Print "[RENDER] lookupKey=", lookupKey
Debug.Print "[RENDER] picPath=", picPath
Dim leftPt As Double, topPt As Double, widthPt As Double, heightPt As Double, ok As Boolean
ok = ComputeAnchorPosition(ws, a, leftPt, topPt, widthPt, heightPt)
Debug.Print "[RENDER] ok=", ok, " left=", leftPt, " top=", topPt, " w=", widthPt, " h=", heightPt
If Not ok Then GoTo NEXT_A
Dim shpName As String
shpName = "ANC_" & CleanKey(picName) & "_" & CStr(idx)
idx = idx + 1
Dim shp As Shape
Set shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, leftPt, topPt, widthPt, heightPt)
shp.name = shpName
shp.LockAspectRatio = MSO_FALSE ' 按锚点尺寸
shp.Placement = XL_MOVE_AND_SIZE
Debug.Print "[RENDERED]", shp.name
NEXT_A:
Next
End Sub
' 直插图：按公式锚点直接在单元格位置插入图片（不依赖 drawings）
Private Sub RenderByFormulaDirect(ByVal ws As Worksheet, ByVal imgFolder As String)
On Error Resume Next
Debug.Print "[RBF-DIRECT] ws:", ws.name
If Len(imgFolder) = 0 Then
Debug.Print "[RBF-DIRECT] skip: no external folder provided"
Exit Sub
End If
Dim rng As Range, c As Range
Set rng = ws.UsedRange
If rng Is Nothing Then Exit Sub
DeleteShapesByPrefix ws, "ANC_"
Dim f As String, id As String, modeVal As Long
Dim tgt As Range, shp As Shape, picPath As String
For Each c In rng.Cells
If c.HasFormula Then
f = vbNullString
On Error Resume Next
f = c.Formula2
If Len(f) = 0 Then f = c.Formula
On Error GoTo 0
If TryParseDispImg(f, id, modeVal) Then
picPath = FindImageById(imgFolder, id)
Debug.Print "[RBF-DIRECT] cell:", ws.name, c.Address(False, False), " id=", id, " path=", picPath
If Len(picPath) > 0 Then
If c.MergeCells Then Set tgt = c.MergeArea Else Set tgt = c
Set shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, tgt.Left, tgt.Top, 10, 10)
shp.LockAspectRatio = MSO_TRUE
FitShapeIntoRange shp, tgt
shp.Placement = XL_MOVE_AND_SIZE
End If
End If
End If
Next
End Sub
Private Sub FitShapeIntoRange(ByVal shp As Shape, ByVal rg As Range)
On Error Resume Next
Dim tw As Double, th As Double
tw = rg.Width: th = rg.Height
If tw <= 0 Or th <= 0 Then Exit Sub
shp.LockAspectRatio = MSO_TRUE
shp.Width = tw
If shp.Height > th Then shp.Height = th
shp.Left = rg.Left + (tw - shp.Width) / 2
shp.Top = rg.Top + (th - shp.Height) / 2
End Sub
Private Sub RenderByFormulaWithEmbedded(ByVal ws As Worksheet, ByVal imgFolder As String, ByVal idFilter As Object, ByVal idEmbedded As Object)
On Error Resume Next
Dim rng As Range, c As Range
Set rng = ws.UsedRange
If rng Is Nothing Then Exit Sub
Dim f As String, id As String, modeVal As Long
Dim tgt As Range, shp As Shape, picPath As String
For Each c In rng.Cells
If c.HasFormula Then
f = vbNullString
On Error Resume Next
f = c.Formula2
If Len(f) = 0 Then f = c.Formula
On Error GoTo 0
If TryParseDispImg(f, id, modeVal) Then
If Not idFilter Is Nothing Then
If Not idFilter.exists(id) Then GoTo NEXT_C
End If
picPath = vbNullString
If Len(imgFolder) > 0 Then
picPath = FindImageById(imgFolder, id)
End If
If Len(picPath) = 0 Then
If Not idEmbedded Is Nothing Then
If idEmbedded.exists(id) Then picPath = CStr(idEmbedded(id))
End If
End If
If Len(picPath) > 0 Then
If c.MergeCells Then Set tgt = c.MergeArea Else Set tgt = c
Set shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, tgt.Left, tgt.Top, 10, 10)
shp.LockAspectRatio = MSO_TRUE
FitShapeIntoRange shp, tgt
shp.Placement = XL_MOVE_AND_SIZE
shp.name = "ANC_CELLIMG_ID_" & CleanKey(id)
Debug.Print "[RENDERED-CELLIMG-FORMULA]", ws.name, c.Address(False, False), id, " -> ", picPath
End If
End If
End If
NEXT_C:
Next
End Sub
' 从锚点(from 节点)对应的单元格解析公式里的 ID
Private Function TryGetIdFromAnchor(ByVal ws As Worksheet, ByVal anchor As Object) As String
On Error Resume Next
Dim fromNode As Object
Set fromNode = anchor.SelectSingleNode(".//*[local-name()='from']")
If fromNode Is Nothing Then Exit Function
Dim c As Long, r As Long
c = CLng(GetChildText(fromNode, "*[local-name()='col']", 0))
r = CLng(GetChildText(fromNode, "*[local-name()='row']", 0))
If r < 0 Or c < 0 Then Exit Function
Dim f As String, id As String, modeVal As Long
f = vbNullString
On Error Resume Next
f = ws.Cells(r + 1, c + 1).Formula2
If Len(f) = 0 Then f = ws.Cells(r + 1, c + 1).Formula
On Error GoTo 0
If TryParseDispImg(f, id, modeVal) Then
TryGetIdFromAnchor = id
End If
End Function
' 计算锚点位置尺寸（点）
Private Function ComputeAnchorPosition(ByVal ws As Worksheet, ByVal anchor As Object, ByRef leftPt As Double, ByRef topPt As Double, ByRef widthPt As Double, ByRef heightPt As Double) As Boolean
Dim fromNode As Object, toNode As Object, extNode As Object
Set fromNode = anchor.SelectSingleNode("./*[local-name()='from']")
Set toNode = anchor.SelectSingleNode("./*[local-name()='to']")
Set extNode = anchor.SelectSingleNode("./*[local-name()='ext']")
Dim fromC As Long, fromR As Long, fromColOffEMU As Double, fromRowOffEMU As Double
Dim toC As Long, toR As Long, toColOffEMU As Double, toRowOffEMU As Double
fromC = 0: fromR = 0: fromColOffEMU = 0: fromRowOffEMU = 0
toC = 0: toR = 0: toColOffEMU = 0: toRowOffEMU = 0
If Not fromNode Is Nothing Then
fromC = CLng(GetChildText(fromNode, "*[local-name()='col']", 0))
fromR = CLng(GetChildText(fromNode, "*[local-name()='row']", 0))
fromColOffEMU = CDbl(GetChildText(fromNode, "*[local-name()='colOff']", 0))
fromRowOffEMU = CDbl(GetChildText(fromNode, "*[local-name()='rowOff']", 0))
End If
If Not toNode Is Nothing Then
toC = CLng(GetChildText(toNode, "*[local-name()='col']", 0))
toR = CLng(GetChildText(toNode, "*[local-name()='row']", 0))
toColOffEMU = CDbl(GetChildText(toNode, "*[local-name()='colOff']", 0))
toRowOffEMU = CDbl(GetChildText(toNode, "*[local-name()='rowOff']", 0))
End If
leftPt = ws.Cells(1, fromC + 1).Left + EmuToPt(fromColOffEMU)
topPt = ws.Cells(fromR + 1, 1).Top + EmuToPt(fromRowOffEMU)
If Not extNode Is Nothing Then
widthPt = EmuToPt(CDbl(GetAttr(extNode, "cx", 0#)))
heightPt = EmuToPt(CDbl(GetAttr(extNode, "cy", 0#)))
If widthPt <= 0 Or heightPt <= 0 Then
ComputeAnchorPosition = False
Exit Function
End If
ElseIf Not toNode Is Nothing Then
Dim rightPt As Double, bottomPt As Double
rightPt = ws.Cells(1, toC + 1).Left + EmuToPt(toColOffEMU)
bottomPt = ws.Cells(toR + 1, 1).Top + EmuToPt(toRowOffEMU)
widthPt = rightPt - leftPt
heightPt = bottomPt - topPt
If widthPt <= 0 Or heightPt <= 0 Then
ComputeAnchorPosition = False
Exit Function
End If
Else
ComputeAnchorPosition = False
Exit Function
End If
ComputeAnchorPosition = True
End Function
' 读取图片的 cNvPr/@name
Private Function GetPicName(ByVal anchor As Object) As String
Dim n As Object
Set n = anchor.SelectSingleNode(".//*[local-name()='cNvPr' and @name]")
If n Is Nothing Then Exit Function
On Error Resume Next
GetPicName = n.Attributes.getNamedItem("name").Text
On Error GoTo 0
End Function
' 收集一个工作表中出现的 DISPIMG("ID_xxx") 的所有 ID
Private Function CollectDispImgIdsOnSheet(ByVal ws As Worksheet) As Object
Dim rng As Range, c As Range
On Error Resume Next
Set rng = ws.UsedRange
On Error GoTo 0
If rng Is Nothing Then Exit Function
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1 ' TextCompare
Dim f As String, id As String, modeVal As Long
For Each c In rng.Cells
If c.HasFormula Then
On Error Resume Next
f = c.Formula2
If Len(f) = 0 Then f = c.Formula
On Error GoTo 0
Debug.Print "[FORMULA]", ws.name, c.Address(False, False), f
If TryParseDispImg(f, id, modeVal) Then
Debug.Print "[PARSED OK]", id, modeVal
If Not d.exists(id) Then d.Add id, True
Else
Debug.Print "[PARSED FAIL]"
End If
End If
Next
Set CollectDispImgIdsOnSheet = d
End Function
' 解析 workbook.xml，把 sheetXml -> sheetName 的映射表建立起来
Private Function MapSheetXmlToName(ByVal unzipDir As String) As Object
On Error GoTo FAIL
Dim wbXml As String
wbXml = AddSlash(unzipDir) & "xl\workbook.xml"
If Len(Dir$(wbXml)) = 0 Then Exit Function
Dim rels As Object ' rId -> target
Set rels = LoadRels(AddSlash(unzipDir) & "xl\_rels\workbook.xml.rels", "")
Dim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")
doc.async = False: doc.validateOnParse = False
doc.SetProperty "SelectionLanguage", "XPath"
If Not doc.Load(wbXml) Then Exit Function
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1
Dim sheet As Object, rid As String, name As String, target As String
For Each sheet In doc.SelectNodes("//*[local-name()='sheets']/*[local-name()='sheet']")
name = GetAttr(sheet, "name", "")
rid = GetAttrNs(sheet, "id", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
If Len(name) > 0 And Len(rid) > 0 Then
If Not rels Is Nothing And rels.exists(rid) Then
target = CStr(rels(rid)) ' e.g. worksheets/sheet1.xml
d(target) = name
End If
End If
Next
Set MapSheetXmlToName = d
Exit Function
FAIL:
End Function
' 根据 sheet 名找回对应的 sheetXml 相对路径
Private Function FindSheetXmlByName(ByVal sheetMap As Object, ByVal sheetName As String) As String
Dim k As Variant
For Each k In sheetMap.Keys
If StrComp(CStr(sheetMap(k)), sheetName, vbTextCompare) = 0 Then
FindSheetXmlByName = CStr(k)
Exit Function
End If
Next
End Function
' 读取 xl/worksheets/_rels/sheetX.xml.rels 里的 drawing 目标
Private Function FindSheetDrawingTarget(ByVal unzipDir As String, ByVal sheetTarget As String) As String
Dim relPath As String
relPath = AddSlash(unzipDir) & "xl\" & GetParentFolder(sheetTarget) & "_rels\" & GetFileName(sheetTarget) & ".rels"
Dim rels As Object
Set rels = LoadRels(relPath, "http://schemas.openxmlformats.org/officeDocument/2006/relationships/drawing")
If rels Is Nothing Then Exit Function
Dim k As Variant
For Each k In rels.Keys
FindSheetDrawingTarget = CStr(rels(k)) ' e.g. ../drawings/drawing1.xml
Exit Function
Next
End Function
' 加载 .rels (可选过滤 Type)，返回 rId -> Target
Private Function LoadRels(ByVal relsPath As String, ByVal typeFilter As String) As Object
If Len(Dir$(relsPath)) = 0 Then
Debug.Print "[RELS] missing", relsPath
Exit Function
End If
Dim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")
doc.async = False: doc.validateOnParse = False
doc.SetProperty "SelectionLanguage", "XPath"
If Not doc.Load(relsPath) Then
Debug.Print "[RELS] load fail", relsPath
Exit Function
End If
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1
Dim rel As Object, id As String, target As String, typ As String
For Each rel In doc.SelectNodes("//*[local-name()='Relationship']")
id = GetAttr(rel, "Id", "")
target = GetAttr(rel, "Target", "")
typ = GetAttr(rel, "Type", "")
If Len(id) > 0 And Len(target) > 0 Then
If Len(typeFilter) = 0 Or StrComp(typ, typeFilter, vbTextCompare) = 0 Then
d(id) = target
End If
End If
Next
Debug.Print "[RELS] loaded", relsPath, " count=", d.Count
Set LoadRels = d
End Function
' 读取 cellimages.xml.rels 中 rid -> name（DISPIMG第一个参数）的映射（WPS常见扩展）
Private Function LoadCellImageRidToNameMap(ByVal relsPath As String) As Object
On Error GoTo FAIL
If Len(Dir$(relsPath)) = 0 Then Exit Function
Dim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")
doc.async = False: doc.validateOnParse = False
doc.SetProperty "SelectionLanguage", "XPath"
If Not doc.Load(relsPath) Then Exit Function
Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1
Dim rel As Object, rid As String, nm As String
For Each rel In doc.SelectNodes("//*[local-name()='Relationship']")
rid = GetAttr(rel, "Id", "")
' WPS资料中常见为 name 或 Name；两者都尝试
nm = GetAttr(rel, "Name", "")
If Len(nm) = 0 Then nm = GetAttr(rel, "name", "")
If Len(rid) > 0 And Len(nm) > 0 Then
d(rid) = nm
End If
Next
Set LoadCellImageRidToNameMap = d
Exit Function
FAIL:
End Function
' =============== 公式清理功能 ===============
' 删除当前活动工作表中的所有 DISPIMG 公式（将单元格置为空文本，保留格式与已插入的图片）
Public Sub DISPIMG_DeleteFormulas_CurrentSheet()
On Error Resume Next
DeleteDispImgFormulasOnSheet ActiveSheet, ""
End Sub
' 删除整个工作簿中所有工作表的 DISPIMG 公式
Public Sub DISPIMG_DeleteFormulas_AllSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
DeleteDispImgFormulasOnSheet ws, ""
Next
MsgBox "已删除所有工作表中的 DISPIMG 公式。", vbInformation
End Sub
' 核心：删除指定工作表中的 DISPIMG 公式
' replacementText 用于写入替换文本，通常为空字符串
Private Sub DeleteDispImgFormulasOnSheet(ByVal ws As Worksheet, ByVal replacementText As String)
On Error Resume Next
Dim rng As Range, c As Range
Set rng = ws.UsedRange
If rng Is Nothing Then Exit Sub
Dim f As String, id As String, modeVal As Long
Dim cnt As Long
For Each c In rng.Cells
If c.HasFormula Then
f = vbNullString
On Error Resume Next
f = c.Formula2
If Len(f) = 0 Then f = c.Formula
On Error GoTo 0
If TryParseDispImg(f, id, modeVal) Then
c.Formula = vbNullString
c.Value = replacementText
cnt = cnt + 1
Debug.Print "[DELETE-DISPIMG]", ws.name, c.Address(False, False), f
End If
End If
Next
Debug.Print "[DELETE-DISPIMG] sheet=", ws.name, " removed=", cnt
End Sub
' =============== 工具函数 ===============
Private Function EmuToPt(ByVal emu As Double) As Double
EmuToPt = emu / 12700#
End Function
Private Function GetChildText(ByVal parent As Object, ByVal xpath As String, ByVal def As Variant) As Variant
Dim n As Object
Set n = parent.SelectSingleNode(xpath)
If n Is Nothing Then
GetChildText = def
Else
GetChildText = n.Text
End If
End Function
Private Function GetAttr(ByVal n As Object, ByVal attrName As String, ByVal def As String) As String
On Error Resume Next
Dim a As Object
Set a = n.Attributes.getNamedItem(attrName)
If a Is Nothing Then
GetAttr = def
Else
GetAttr = a.Text
End If
End Function
Private Function GetAttrNs(ByVal n As Object, ByVal localName As String, ByVal nsUri As String, ByVal def As String) As String
On Error Resume Next
Dim a As Object, i As Long
For i = 0 To n.Attributes.Length - 1
Set a = n.Attributes.Item(i)
If Not a Is Nothing Then
If InStr(1, a.nodeName, ":" & localName, vbTextCompare) > 0 Then
If CStr(a.NamespaceURI) = nsUri Then
GetAttrNs = a.Text
Exit Function
End If
End If
End If
Next
GetAttrNs = def
End Function
Private Sub DeleteShapesByPrefix(ByVal ws As Worksheet, ByVal prefix As String)
Dim i As Long
For i = ws.Shapes.Count To 1 Step -1
If Left$(ws.Shapes(i).name, Len(prefix)) = prefix Then
On Error Resume Next
ws.Shapes(i).Delete
On Error GoTo 0
End If
Next
End Sub
Private Function CleanKey(ByVal s As String) As String
Dim t As String
t = s
t = Replace(t, ":", "_")
t = Replace(t, "/", "_")
t = Replace(t, "\", "_")
t = Replace(t, " ", "_")
CleanKey = t
End Function
' 将工作簿复制为 zip 并解压到目标文件夹
Private Function UnzipWorkbookToFolder(ByVal wbPath As String, ByVal destDir As String) As Boolean
On Error GoTo FAIL
Debug.Print "[UNZIP] start wb=", wbPath, " dest=", destDir
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(destDir) Then fso.CreateFolder destDir
Dim zipPath As String: zipPath = AddSlash(destDir) & "src.zip"
Debug.Print "[UNZIP] zipPath=", zipPath
On Error Resume Next
fso.CopyFile wbPath, zipPath, True
If Err.Number <> 0 Then
Debug.Print "[UNZIP] CopyFile err=", Err.Number, Err.Description
Err.Clear
End If
On Error GoTo FAIL
If Len(Dir$(zipPath)) = 0 Then
Debug.Print "[UNZIP] zip not created, fallback to PS"
If UnzipWithPowerShellLocal(wbPath, destDir) Then
UnzipWorkbookToFolder = True
Exit Function
Else
GoTo FAIL
End If
End If
Dim sh As Object: Set sh = CreateObject("Shell.Application")
Dim src As Object, dst As Object
Set src = sh.Namespace(CStr(zipPath))
Set dst = sh.Namespace(CStr(destDir))
Debug.Print "[UNZIP] shell src/dst ok=", (Not src Is Nothing) And (Not dst Is Nothing)
If src Is Nothing Or dst Is Nothing Then
Debug.Print "[UNZIP] shell unzip not available, try PS"
If UnzipWithPowerShellLocal(zipPath, destDir) Then
UnzipWorkbookToFolder = True
Exit Function
Else
GoTo FAIL
End If
End If
Debug.Print "[UNZIP] CopyHere items=", src.items.Count
Const FOF_SILENT As Long = 4
Const FOF_NOCONFIRMATION As Long = 16
Const FOF_NOCONFIRMMKDIR As Long = 512
Const FOF_NOERRORUI As Long = 1024
dst.CopyHere src.items, FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR Or FOF_NOERRORUI
' 等待关键文件出现，最多 8 秒
Dim t As Single: t = Timer
Do While Len(Dir$(AddSlash(destDir) & "xl\workbook.xml")) = 0 And (Timer - t < 8)
DoEvents
Loop
Dim exists As Boolean
exists = (Len(Dir$(AddSlash(destDir) & "xl\workbook.xml")) > 0)
Debug.Print "[UNZIP] workbook.xml exists=", exists, " elapsed=", (Timer - t)
If Not exists Then
Debug.Print "[UNZIP] shell unzip not yielding files, try PS"
If UnzipWithPowerShellLocal(zipPath, destDir) Then
UnzipWorkbookToFolder = True
Exit Function
Else
GoTo FAIL
End If
End If
UnzipWorkbookToFolder = True
Exit Function
FAIL:
Debug.Print "[UNZIP] FAIL Err=", Err.Number, " Desc=", Err.Description
UnzipWorkbookToFolder = False
End Function
Private Function UnzipWithPowerShellLocal(ByVal zipFilePath As String, ByVal destinationPath As String) As Boolean
On Error GoTo EH
Dim wsh As Object: Set wsh = CreateObject("WScript.Shell")
Dim quotedZip As String, quotedDest As String
quotedZip = PSQuoteLocal(zipFilePath)
quotedDest = PSQuoteLocal(destinationPath)
Dim cmd As String
cmd = "powershell -NoProfile -NonInteractive -ExecutionPolicy Bypass -Command " & _
"Try { Expand-Archive -LiteralPath " & quotedZip & " -DestinationPath " & quotedDest & " -Force; exit 0 } Catch { exit 1 }"
Dim rc As Long
rc = wsh.Run(cmd, 0, True) ' wait
If rc = 0 Then
' verify result
UnzipWithPowerShellLocal = (Len(Dir$(AddSlash(destinationPath) & "xl\workbook.xml")) > 0)
Else
UnzipWithPowerShellLocal = False
End If
Exit Function
EH:
UnzipWithPowerShellLocal = False
End Function
Private Function ResolveEmbeddedImageFromAnchor(ByVal drawingXmlPath As String, ByVal anchor As Object) As String
On Error GoTo FAIL
' 1) 从 anchor 内找到 a:blip 的 embed/link（不依赖命名空间前缀）
Dim blip As Object
Set blip = anchor.SelectSingleNode(".//*[local-name()='blip' and @*[local-name()='embed']]")
If blip Is Nothing Then
Set blip = anchor.SelectSingleNode(".//*[local-name()='blip' and @*[local-name()='link']]")
End If
If blip Is Nothing Then Exit Function
Dim rid As String
rid = GetAttrNs(blip, "embed", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
If Len(rid) = 0 Then
rid = GetAttrNs(blip, "link", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
End If
If Len(rid) = 0 Then Exit Function
' 2) 打开 drawing.xml.rels，找到 rId 对应的 Target
Dim relsPath As String
relsPath = Left$(drawingXmlPath, InStrRev(drawingXmlPath, "\")) & "_rels\" & Mid$(drawingXmlPath, InStrRev(drawingXmlPath, "\") + 1) & ".rels"
Dim rels As Object
Set rels = LoadRels(relsPath, "")
If rels Is Nothing Then Exit Function
Dim target As String
If Not rels.exists(rid) Then Exit Function
target = CStr(rels(rid)) ' e.g. ../media/image1.png 或 media/image1.png
' 3) 解析真实路径，优先返回解压目录里的文件路径
Dim baseDir As String
baseDir = Left$(drawingXmlPath, InStrRev(drawingXmlPath, "\") - 1) ' ...\xl\drawings
Dim unzipRoot As String
unzipRoot = Left$(baseDir, InStrRev(baseDir, "\") - 1) ' ...\xl
Dim mediaPath As String
If InStr(1, target, "../", vbTextCompare) > 0 Then
mediaPath = unzipRoot & "\" & Replace(target, "../", "")
Else
mediaPath = baseDir & "\" & target
End If
mediaPath = NormalizePath(mediaPath)
If Len(Dir$(mediaPath)) > 0 Then ResolveEmbeddedImageFromAnchor = mediaPath
Exit Function
FAIL:
End Function
Private Function PSQuoteLocal(ByVal s As String) As String
PSQuoteLocal = "'" & Replace(s, "'", "''") & "'"
End Function
' 创建临时目录（root 为空则用可写的临时目录，含多级回退）
Private Function CreateTempFolder(ByVal root As String) As String
On Error GoTo FAIL
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim candidates As Collection: Set candidates = New Collection
' 优先使用调用方指定
If Len(root) > 0 Then candidates.Add root
' 常见临时目录候选
candidates.Add Environ$("LOCALAPPDATA") & "\Temp"
candidates.Add Environ$("TEMP")
candidates.Add fso.GetSpecialFolder(2) ' TempFolder
' 回退到桌面/Temp
On Error Resume Next
candidates.Add CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Temp"
On Error GoTo 0
' 最后回退 C:\Temp（若有权限）
candidates.Add "C:\Temp"
Dim base As String, testPath As String
Dim c As Variant
For Each c In candidates
base = CStr(c)
If Len(base) = 0 Then GoTo NEXT_BASE
Debug.Print "[TMP] try base=", base
If EnsureFolderLocal(base) Then
' 写入测试
testPath = AddSlash(base) & "perm_test_" & Format(Now, "yyyymmddhhnnss") & "_" & CLng(Rnd() * 100000)
On Error Resume Next
fso.CreateFolder testPath
If Err.Number = 0 Then
fso.DeleteFolder testPath, True
On Error GoTo 0
Exit For
End If
Debug.Print "[TMP] base not writable, err=", Err.Number, Err.Description
Err.Clear
On Error GoTo 0
End If
NEXT_BASE:
Next
If Len(base) = 0 Then GoTo FAIL
' 创建唯一子目录
Dim i As Long, p As String
For i = 1 To 5
p = AddSlash(base) & "xl_temp_" & Format(Now, "yyyymmddhhnnss") & "_" & CLng(Rnd() * 1000000)
On Error Resume Next
fso.CreateFolder p
If Err.Number = 0 Then
On Error GoTo 0
Debug.Print "[TMP] created=", p
CreateTempFolder = p
Exit Function
End If
Debug.Print "[TMP] create fail err=", Err.Number, Err.Description
Err.Clear
On Error GoTo 0
Next
FAIL:
Debug.Print "[TMP] CreateTempFolder FAIL err=", Err.Number, Err.Description
CreateTempFolder = ""
End Function
' 递归确保目录存在
Private Function EnsureFolderLocal(ByVal folderPath As String) As Boolean
On Error Resume Next
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(folderPath) Then EnsureFolderLocal = True: Exit Function
Dim parent As String: parent = fso.GetParentFolderName(folderPath)
If Len(parent) > 0 Then
If Not fso.FolderExists(parent) Then
If Not EnsureFolderLocal(parent) Then Exit Function
End If
End If
Dim fld As Object: Set fld = fso.CreateFolder(folderPath)
EnsureFolderLocal = Not fld Is Nothing
End Function
Private Sub DeleteFolderSilent(ByVal p As String)
On Error Resume Next
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(p) Then fso.DeleteFolder p, True
End Sub
Private Function AddSlash(ByVal p As String) As String
If Right$(p, 1) = "\" Or Right$(p, 1) = "/" Then AddSlash = p Else AddSlash = p & "\"
End Function
Private Function NormalizePath(ByVal p As String) As String
NormalizePath = Replace(p, "/", "\")
End Function
Private Function GetParentFolder(ByVal rel As String) As String
Dim i As Long
i = InStrRev(rel, "/")
If i = 0 Then
GetParentFolder = ""
Else
GetParentFolder = Left$(rel, i)
End If
End Function
Private Function GetFileName(ByVal rel As String) As String
Dim i As Long
i = InStrRev(rel, "/")
If i = 0 Then
GetFileName = rel
Else
GetFileName = Mid$(rel, i + 1)
End If
End Function
' Parse cell image position from various WPS/Excel variants:
' - attributes row/col (zero-based)
' - attributes r/c (zero-based)
' - child nodes <row>/<col>
' - attribute ref in A1 (or range "A1:B2" -> first cell)
Private Function TryGetCellImageRowCol(ByVal it As Object, ByRef r As Long, ByRef c As Long) As Boolean
Dim sRow As String, sCol As String, ref As String
' 1) row/col attributes
sRow = GetAttr(it, "row", "")
sCol = GetAttr(it, "col", "")
If Len(sRow) > 0 And Len(sCol) > 0 Then
r = CLng(sRow)
c = CLng(sCol)
TryGetCellImageRowCol = True
Exit Function
End If
' 2) r/c attributes (WPS variants)
sRow = GetAttr(it, "r", "")
sCol = GetAttr(it, "c", "")
If Len(sRow) > 0 And Len(sCol) > 0 Then
r = CLng(sRow)
c = CLng(sCol)
TryGetCellImageRowCol = True
Exit Function
End If
' 3) child nodes <row>/<col> directly under item
On Error Resume Next
sRow = vbNullString: sCol = vbNullString
Dim rn As Object, cn As Object
Set rn = it.SelectSingleNode("./*[local-name()='row']")
Set cn = it.SelectSingleNode("./*[local-name()='col']")
If Not rn Is Nothing Then sRow = rn.Text
If Not cn Is Nothing Then sCol = cn.Text
On Error GoTo 0
If Len(sRow) > 0 And Len(sCol) > 0 Then
r = CLng(sRow)
c = CLng(sCol)
TryGetCellImageRowCol = True
Exit Function
End If
' 3b) nested from node (e.g., .//*[local-name()='anchor']/*[local-name()='from'])
Dim fromN As Object, rowN As Object, colN As Object
Set fromN = it.SelectSingleNode(".//*[local-name()='from']")
If Not fromN Is Nothing Then
sRow = vbNullString: sCol = vbNullString
Set rowN = fromN.SelectSingleNode("./*[local-name()='row']")
Set colN = fromN.SelectSingleNode("./*[local-name()='col']")
If Not rowN Is Nothing Then sRow = rowN.Text
If Not colN Is Nothing Then sCol = colN.Text
' some variants store as attributes on from
If Len(sRow) = 0 Then sRow = GetAttr(fromN, "row", "")
If Len(sCol) = 0 Then sCol = GetAttr(fromN, "col", "")
If Len(sRow) > 0 And Len(sCol) > 0 Then
r = CLng(sRow)
c = CLng(sCol)
TryGetCellImageRowCol = True
Exit Function
End If
End If
' 4) ref-like attributes (namespaced): @ref / @cell / @sqref (take first A1)
On Error Resume Next
Dim attrRef As Object
Set attrRef = it.SelectSingleNode("@*[local-name()='ref' or local-name()='cell' or local-name()='sqref']")
On Error GoTo 0
If Not attrRef Is Nothing Then
ref = CStr(attrRef.Text)
If Len(ref) > 0 Then
Dim a1 As String, p As Long
p = InStr(1, ref, ":", vbTextCompare)
If p > 0 Then a1 = Left$(ref, p - 1) Else a1 = ref
If TryParseA1Ref(a1, r, c) Then
TryGetCellImageRowCol = True
Exit Function
End If
End If
End If
' 4b) plain ref attribute (non-namespaced)
ref = GetAttr(it, "ref", "")
If Len(ref) > 0 Then
Dim a1x As String, px As Long
px = InStr(1, ref, ":", vbTextCompare)
If px > 0 Then a1x = Left$(ref, px - 1) Else a1x = ref
If TryParseA1Ref(a1x, r, c) Then
TryGetCellImageRowCol = True
Exit Function
End If
End If
TryGetCellImageRowCol = False
End Function
' Convert A1 string (e.g. "E71") to zero-based row/col
Private Function TryParseA1Ref(ByVal a1 As String, ByRef r As Long, ByRef c As Long) As Boolean
Dim s As String: s = UCase$(Trim$(a1))
If Len(s) = 0 Then Exit Function
Dim i As Long, letters As String, digits As String, ch As String
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If ch >= "A" And ch <= "Z" Then
letters = letters & ch
ElseIf ch >= "0" And ch <= "9" Then
digits = Mid$(s, i)
Exit For
Else
Exit Function
End If
Next
If Len(letters) = 0 Or Len(digits) = 0 Then Exit Function
Dim colIndex As Long: colIndex = ColLettersToIndex(letters)
If colIndex <= 0 Then Exit Function
r = CLng(digits) - 1
c = colIndex - 1
TryParseA1Ref = (r >= 0 And c >= 0)
End Function
Private Function ColLettersToIndex(ByVal letters As String) As Long
Dim i As Long, v As Long, ch As String
For i = 1 To Len(letters)
ch = Mid$(letters, i, 1)
If ch < "A" Or ch > "Z" Then Exit Function
v = v * 26 + (Asc(ch) - Asc("A") + 1)
Next
ColLettersToIndex = v
End Function
' 在目录中查找图片文件（支持中文名称和ID命名）
Private Function FindImageById(ByVal folder As String, ByVal imgId As String) As String
Debug.Print "[FINDIMG] Looking for:", imgId, " in folder:", folder
' 首先尝试直接匹配文件名（支持中文名称如"图片 1"）
Dim extArr, i As Long, tryPath As String
extArr = Array(".png", ".jpg", ".jpeg", ".bmp", ".gif", ".webp")
' 尝试直接匹配完整文件名
For i = LBound(extArr) To UBound(extArr)
tryPath = AddSlash(folder) & imgId & extArr(i)
Debug.Print "[FINDIMG] Trying direct:", tryPath, " exists=", (Len(Dir$(tryPath)) > 0)
If Len(Dir$(tryPath)) > 0 Then
Debug.Print "[FINDIMG] Found direct match:", tryPath
FindImageById = tryPath
Exit Function
End If
Next
' 如果直接匹配失败，尝试通配符搜索
Dim f As String
Dim wildcardPattern As String
wildcardPattern = AddSlash(folder) & imgId & ".*"
Debug.Print "[FINDIMG] Trying wildcard:", wildcardPattern
f = Dir$(wildcardPattern)
Debug.Print "[FINDIMG] Wildcard result:", f
If Len(f) > 0 Then
Dim resultPath As String
resultPath = AddSlash(folder) & f
Debug.Print "[FINDIMG] Found wildcard match:", resultPath
FindImageById = resultPath
Exit Function
End If
Debug.Print "[FINDIMG] No match found for:", imgId
FindImageById = ""
End Function
' 解析公式文本中的 DISPIMG("ID_...")
Private Function TryParseDispImg(ByVal formulaText As String, ByRef outId As String, ByRef outMode As Long) As Boolean
Dim re As Object: Set re = CreateObject("VBScript.RegExp")
re.Global = False
re.IgnoreCase = True
re.Pattern = "(@_?xlfn\.)?DISPIMG\s*\(\s*""(ID_?[A-F0-9]{32})""\s*(,\s*([0-9]+))?"
Dim m As Object
If re.Test(formulaText) Then
Set m = re.Execute(formulaText)
outId = m(0).SubMatches(1)
If m(0).SubMatches.Count >= 4 And Len(m(0).SubMatches(3)) > 0 Then
outMode = CLng(m(0).SubMatches(3))
Else
outMode = 1
End If
TryParseDispImg = True
Else
TryParseDispImg = False
End If
End Function
' 选择文件夹对话框
Private Function PickFolder(ByVal title As String) As String
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
.title = title
If .Show = -1 Then PickFolder = .SelectedItems(1) Else PickFolder = ""
End With
End Function
' 读取 xl/worksheets/_rels/sheetX.xml.rels 里的 cellimages 目标（Excel 365 单元格图片）
Private Function FindSheetCellImagesTarget(ByVal unzipDir As String, ByVal sheetTarget As String) As String
Dim relPath As String
relPath = AddSlash(unzipDir) & "xl\" & GetParentFolder(sheetTarget) & "_rels\" & GetFileName(sheetTarget) & ".rels"
Dim rels As Object
Set rels = LoadRels(relPath, "")
If rels Is Nothing Then Exit Function
Dim k As Variant, target As String
For Each k In rels.Keys
target = CStr(rels(k))
If InStr(1, target, "cellimage", vbTextCompare) > 0 Or InStr(1, target, "cellimages", vbTextCompare) > 0 Then
FindSheetCellImagesTarget = target ' e.g. ../cellimages/cellimages.xml
Exit Function
End If
Next
End Function
' 渲染 Excel 365 的单元格图片（xl/cellimages/cellimages.xml）
Private Sub RenderCellImagesToSheet(ByVal ws As Worksheet, ByVal unzipDir As String, ByVal sheetTarget As String, ByVal imgFolder As String, ByVal idFilter As Object)
On Error GoTo EXIT_SUB
Dim cellTarget As String
cellTarget = FindSheetCellImagesTarget(unzipDir, sheetTarget)
Dim cellXml As String
If Len(cellTarget) > 0 Then
cellXml = NormalizePath(AddSlash(unzipDir) & "xl\" & Replace(cellTarget, "../", ""))
Else
' WPS fallback: try workbook-level cellimages parts
Dim cand1 As String, cand2 As String
cand1 = NormalizePath(AddSlash(unzipDir) & "xl\cellimages.xml")
cand2 = NormalizePath(AddSlash(unzipDir) & "xl\cellimages\cellimages.xml")
If Len(Dir$(cand1)) > 0 Then
cellXml = cand1
ElseIf Len(Dir$(cand2)) > 0 Then
cellXml = cand2
Else
Debug.Print "[CELLIMG] not found under xl: cellimages.xml or cellimages\cellimages.xml"
GoTo EXIT_SUB
End If
End If
Debug.Print "[CELLIMG] cellXml=", cellXml
If Len(Dir$(cellXml)) = 0 Then GoTo EXIT_SUB
Dim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")
doc.async = False: doc.validateOnParse = False
doc.SetProperty "SelectionLanguage", "XPath"
If Not doc.Load(cellXml) Then Exit Sub
Dim relsPath As String
relsPath = Left$(cellXml, InStrRev(cellXml, "\")) & "_rels\" & Mid$(cellXml, InStrRev(cellXml, "\") + 1) & ".rels"
Dim rels As Object
Set rels = LoadRels(relsPath, "")
If rels Is Nothing Then Exit Sub
Dim ridToName As Object
Set ridToName = LoadCellImageRidToNameMap(relsPath)
Dim items As Object, it As Object
Set items = doc.SelectNodes("//*[local-name()='cellImage']")
On Error Resume Next
Debug.Print "[CELLIMG] items count=", items.Length
On Error GoTo 0
Dim r As Long, c As Long
Dim rid As String, target As String, mediaPath As String
Dim rowAttr As String, colAttr As String
Dim unzipRoot As String, baseDir As String
baseDir = Left$(cellXml, InStrRev(cellXml, "\") - 1) ' ...\xl\cellimages
unzipRoot = Left$(baseDir, InStrRev(baseDir, "\") - 1) ' ...\xl
' Build ID -> embedded media path map from cellimages (cNvPr@name "ID_..." + blip@r:embed -> rels -> media)
Dim idEmbedded As Object
Set idEmbedded = CreateObject("Scripting.Dictionary")
idEmbedded.CompareMode = 1
Dim it2 As Object, nameN As Object, blN As Object
Dim rid2 As String, idKey As String, target2 As String, mediaPath2 As String
For Each it2 In items
Set nameN = it2.SelectSingleNode(".//*[local-name()='cNvPr']")
idKey = ""
If Not nameN Is Nothing Then
idKey = GetAttr(nameN, "name", "")
If Len(idKey) > 0 And InStr(1, idKey, "ID_", vbTextCompare) = 1 Then
Set blN = it2.SelectSingleNode(".//*[local-name()='blip']")
rid2 = vbNullString
If Not blN Is Nothing Then
rid2 = GetAttrNs(blN, "embed", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
If Len(rid2) = 0 Then
rid2 = GetAttrNs(blN, "link", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
End If
End If
If Len(rid2) > 0 Then
If rels.exists(rid2) Then
target2 = CStr(rels(rid2))
If InStr(1, target2, "../", vbTextCompare) > 0 Then
mediaPath2 = unzipRoot & "\" & Replace(target2, "../", "")
Else
mediaPath2 = baseDir & "\" & target2
End If
mediaPath2 = NormalizePath(mediaPath2)
If Len(Dir$(mediaPath2)) > 0 Then
If Not idEmbedded.exists(idKey) Then idEmbedded.Add idKey, mediaPath2
Debug.Print "[CELLIMG] map ID->embedded:", idKey, " -> ", mediaPath2
End If
End If
End If
End If
End If
Next
' WPS policy: avoid using row/col from cellimages.xml; always render by formula + ID/embedded map
RenderByFormulaWithEmbedded ws, imgFolder, idFilter, idEmbedded
GoTo EXIT_SUB
Dim renderedCount As Long
renderedCount = 0
Dim shp As Shape, tgt As Range, f As String, id As String, modeVal As Long
Dim picPath As String
For Each it In items
If Not TryGetCellImageRowCol(it, r, c) Then
Debug.Print "[CELLIMG] skip: no row/col for item"
GoTo NEXT_IT
End If
' Determine effective cell coordinates:
' default assume zero-based -> Excel row/col = r+1, c+1
Dim rr As Long, cc As Long, usedOneBased As Boolean
rr = r + 1: cc = c + 1: usedOneBased = False
' Optional formula filter (try zero-based first)
id = vbNullString: f = vbNullString: modeVal = 0
If Not idFilter Is Nothing Then
On Error Resume Next
f = ws.Cells(rr, cc).Formula2
If Len(f) = 0 Then f = ws.Cells(rr, cc).Formula
On Error GoTo 0
If Not TryParseDispImg(f, id, modeVal) Then
' WPS may store 1-based row/col; try r,c directly
If r >= 1 And c >= 1 Then
Dim f2 As String
On Error Resume Next
f2 = ws.Cells(r, c).Formula2
If Len(f2) = 0 Then f2 = ws.Cells(r, c).Formula
On Error GoTo 0
If TryParseDispImg(f2, id, modeVal) Then
rr = r: cc = c
usedOneBased = True
f = f2
Else
GoTo NEXT_IT
End If
Else
GoTo NEXT_IT
End If
End If
If Not idFilter.exists(id) Then GoTo NEXT_IT
End If
Debug.Print "[CELLIMG] pos R", rr, "C", cc, " oneBased=", usedOneBased
' Keep the DISPIMG id parsed earlier (from rr,cc when idFilter is provided). No re-parse here.
' 通过 cellimages.xml.rels 解析媒体文件（兼容 WPS：rid 可能在嵌套 blip 上）
rid = GetAttrNs(it, "id", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
If Len(rid) = 0 Then
Dim bl As Object
Set bl = it.SelectSingleNode(".//*[local-name()='blip' and @*[local-name()='embed']]")
If Not bl Is Nothing Then rid = GetAttrNs(bl, "embed", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
If Len(rid) = 0 Then
Set bl = it.SelectSingleNode(".//*[local-name()='blip' and @*[local-name()='link']]")
If Not bl Is Nothing Then rid = GetAttrNs(bl, "link", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")
End If
End If
If Len(rid) = 0 Then GoTo NEXT_IT
If Not rels.exists(rid) Then
Debug.Print "[CELLIMG] rid not in rels:", rid, " relsPath=", relsPath
GoTo NEXT_IT
End If
target = CStr(rels(rid)) ' ../media/imageN.png 或 media/imageN.png
Debug.Print "[CELLIMG] rid=", rid, " target=", target
' 若单元格未能解析出ID，则通过 rels 的 name 属性反查 DISPIMG 第1参数
If Len(id) = 0 Then
If Not ridToName Is Nothing Then
If ridToName.exists(rid) Then
id = CStr(ridToName(rid))
End If
End If
End If
If Len(id) > 0 Then
Debug.Print "[CELLIMG] rid name(id)=", id
End If
If InStr(1, target, "../", vbTextCompare) > 0 Then
mediaPath = unzipRoot & "\" & Replace(target, "../", "")
Else
mediaPath = baseDir & "\" & target
End If
mediaPath = NormalizePath(mediaPath)
' External priority (by ID) else fallback to embedded
picPath = vbNullString
If Len(imgFolder) > 0 And Len(id) > 0 Then
picPath = FindImageById(imgFolder, id)
End If
If Len(picPath) = 0 And Len(Dir$(mediaPath)) > 0 Then
picPath = mediaPath
Debug.Print "[CELLIMG] using embedded:", ws.name, " R", rr, "C", cc, " -> ", picPath
End If
If Len(picPath) = 0 Then GoTo NEXT_IT
' Insert and fit
If ws.Cells(rr, cc).MergeCells Then
Set tgt = ws.Cells(rr, cc).MergeArea
Else
Set tgt = ws.Cells(rr, cc)
End If
Set shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, tgt.Left, tgt.Top, 10, 10)
shp.LockAspectRatio = MSO_TRUE
FitShapeIntoRange shp, tgt
shp.Placement = XL_MOVE_AND_SIZE
shp.name = "ANC_CELLIMG_R" & (r + 1) & "C" & (c + 1)
renderedCount = renderedCount + 1
Debug.Print "[RENDERED-CELLIMG]", shp.name
NEXT_IT:
Next
If renderedCount = 0 Then
Debug.Print "[CELLIMG] no positioned items rendered; fallback by formula with embedded map"
RenderByFormulaWithEmbedded ws, imgFolder, idFilter, idEmbedded
End If
EXIT_SUB:
End Sub
``
浙公网安备 33010602011771号