针对 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", NowDim imgFolder As StringimgFolder = PickFolder("请选择图片所在文件夹（取消则仅用内嵌图片）")Debug.Print "[ENTRY] folder=", imgFolderIf Len(imgFolder) = 0 ThenDebug.Print "[ENTRY] cancelled -> use embedded images"' proceed with embedded images onlyEnd IfDISPIMG_RenderAllAnchors imgFolder
End Sub' 交互式：选择图片目录，仅渲染当前工作簿中各表的 DISPIMG 公式引用到的 ID
Public Sub DISPIMG_QuickRenderByFormula()Dim imgFolder As StringimgFolder = PickFolder("请选择图片所在文件夹（取消则仅用内嵌图片）")' If no folder chosen, proceed with embedded images onlyDISPIMG_RenderByFormula imgFolder
End Sub' 按锚点渲染所有图片（所有工作表，不管是否有公式）
Public Sub DISPIMG_RenderAllAnchors(ByVal imgFolder As String)Dim wb As Workbook: Set wb = ActiveWorkbookIf Len(Dir$(wb.FullName)) = 0 ThenMsgBox "请先保存工作簿再运行。", vbExclamationExit SubEnd IfDebug.Print "[RBF] wb.FullName=", wb.FullNameDebug.Print "[RBF] wb.FullName=", wb.FullNameApplication.ScreenUpdating = FalseApplication.EnableEvents = FalseOn Error GoTo CLEANUPDim tmpRoot As String, unzipDir As StringtmpRoot = CreateTempFolder("")Debug.Print "[RBF] tmpRoot=", tmpRootIf Len(tmpRoot) = 0 ThenMsgBox "无法创建临时目录（根）。请检查权限或磁盘空间。", vbExclamationGoTo CLEANUPEnd IfOn Error GoTo CLEANUPunzipDir = CreateTempFolder(tmpRoot)Debug.Print "[RBF] unzipDir=", unzipDirIf Len(unzipDir) = 0 ThenMsgBox "无法创建临时目录（解压目标）。请检查权限或磁盘空间。", vbExclamationGoTo CLEANUPEnd IfDebug.Print "[RBF] Call Unzip:", wb.FullName, " -> ", unzipDirIf Not UnzipWorkbookToFolder(wb.FullName, unzipDir) ThenDebug.Print "[RBF] Unzip failed for:", wb.FullName, " -> ", unzipDirMsgBox "解压失败。", vbCriticalGoTo CLEANUPEnd IfDim sheetMap As Object ' Scripting.Dictionary (sheetXml -> sheetName)Set sheetMap = MapSheetXmlToName(unzipDir)If sheetMap Is Nothing Or sheetMap.Count = 0 Then GoTo CLEANUPDim key As VariantFor Each key In sheetMap.KeysDim sheetXml As String: sheetXml = CStr(key)Dim sheetName As String: sheetName = CStr(sheetMap(key))Dim ws As WorksheetOn Error Resume NextSet ws = wb.Worksheets(sheetName)On Error GoTo 0If ws Is Nothing Then GoTo NEXT_SHEETDim drawingRel As StringdrawingRel = FindSheetDrawingTarget(unzipDir, sheetXml)If Len(drawingRel) = 0 Then GoTo NEXT_SHEETDim drawingXml As StringdrawingXml = NormalizePath(AddSlash(unzipDir) & "xl\" & Replace(drawingRel, "../", ""))If Len(Dir$(drawingXml)) = 0 Then GoTo NEXT_SHEETDeleteShapesByPrefix 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 = NothingNextMsgBox "锚点渲染完成。", vbInformationCLEANUP:On Error Resume NextIf Len(unzipDir) > 0 Then DeleteFolderSilent unzipDirIf Len(tmpRoot) > 0 Then DeleteFolderSilent tmpRootApplication.EnableEvents = TrueApplication.ScreenUpdating = True
End Sub' 仅渲染各表中公式里引用到的 ID（DISPIMG("ID_xxx"...)）
Public Sub DISPIMG_RenderByFormula(ByVal imgFolder As String)Debug.Print "[RBF] Start", Now, " imgFolder=", imgFolderDim wb As Workbook: Set wb = ActiveWorkbookIf Len(Dir$(wb.FullName)) = 0 ThenMsgBox "请先保存工作簿再运行。", vbExclamationExit SubEnd IfApplication.ScreenUpdating = FalseApplication.EnableEvents = FalseOn Error GoTo CLEANUPDim tmpRoot As String, unzipDir As StringtmpRoot = CreateTempFolder("")Debug.Print "[RBF] tmpRoot=", tmpRootIf Len(tmpRoot) = 0 ThenMsgBox "无法创建临时目录（根）。请检查权限或磁盘空间。", vbExclamationGoTo CLEANUPEnd IfunzipDir = CreateTempFolder(tmpRoot)Debug.Print "[RBF] unzipDir=", unzipDirIf Len(unzipDir) = 0 ThenMsgBox "无法创建临时目录（解压目标）。请检查权限或磁盘空间。", vbExclamationGoTo CLEANUPEnd IfDebug.Print "[RBF] Call Unzip:", wb.FullName, " -> ", unzipDirIf Not UnzipWorkbookToFolder(wb.FullName, unzipDir) ThenDebug.Print "[RBF] Unzip failed for:", wb.FullName, " -> ", unzipDirMsgBox "解压失败。", vbCriticalGoTo CLEANUPEnd IfDim sheetMap As Object ' Scripting.DictionarySet sheetMap = MapSheetXmlToName(unzipDir)If sheetMap Is Nothing Or sheetMap.Count = 0 ThenDebug.Print "[RBF] sheetMap empty"GoTo CLEANUPEnd IfDim ws As WorksheetFor Each ws In wb.WorksheetsDebug.Print "[RBF] WS:", ws.nameDim ids As Object ' Scripting.DictionarySet ids = CollectDispImgIdsOnSheet(ws)If ids Is Nothing ThenDebug.Print "[RBF] ids=None"GoTo NEXT_WSEnd IfDebug.Print "[RBF] ids.Count=", ids.CountIf ids.Count > 0 ThenDim sheetXml As String: sheetXml = FindSheetXmlByName(sheetMap, ws.name)Debug.Print "[RBF] sheetXml=", sheetXmlIf Len(sheetXml) = 0 Then GoTo NEXT_WSDim drawingRel As String: drawingRel = FindSheetDrawingTarget(unzipDir, sheetXml)Debug.Print "[RBF] drawingRel=", drawingRelIf Len(drawingRel) = 0 Then GoTo NEXT_WSDim drawingXml As StringdrawingXml = NormalizePath(AddSlash(unzipDir) & "xl\" & Replace(drawingRel, "../", ""))Debug.Print "[RBF] drawingXml=", drawingXml, " exists=", (Len(Dir$(drawingXml)) > 0)If Len(Dir$(drawingXml)) = 0 Then GoTo NEXT_WSDeleteShapesByPrefix ws, "ANC_"Debug.Print "[RBF] Render sheet", ws.nameDim shapesBefore As Long: shapesBefore = ws.Shapes.CountRenderDrawingAnchorsToSheet ws, drawingXml, imgFolder, ids' Also render Excel 365 cell images (cellimages.xml) per formula filterRenderCellImagesToSheet ws, unzipDir, sheetXml, imgFolder, idsDim added As Long: added = ws.Shapes.Count - shapesBeforeDebug.Print "[RBF] anchors rendered diff=", addedIf added <= 0 ThenDebug.Print "[RBF] fallback to formula-direct on ws:", ws.nameRenderByFormulaDirect ws, imgFolderEnd IfEnd If
NEXT_WS:NextMsgBox "按公式匹配的锚点渲染完成。", vbInformationCLEANUP:Debug.Print "[RBF] CLEANUP enter Err.Number=", Err.Number, " Desc=", Err.DescriptionOn Error Resume NextIf Len(unzipDir) > 0 Then DeleteFolderSilent unzipDirIf Len(tmpRoot) > 0 Then DeleteFolderSilent tmpRootApplication.EnableEvents = TrueApplication.ScreenUpdating = TrueDebug.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", NowDISPIMG_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", NowDISPIMG_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.DOMDocument60Set doc = CreateObject("MSXML2.DOMDocument.6.0")doc.async = False: doc.validateOnParse = Falsedoc.SetProperty "SelectionLanguage", "XPath"If Not doc.Load(drawingXmlPath) Then Exit SubDim anchors As Object, a As ObjectSet anchors = doc.SelectNodes("//*[local-name()='oneCellAnchor' or local-name()='twoCellAnchor']")On Error Resume NextDebug.Print "[DRAW] anchors count=", anchors.LengthOn Error GoTo 0Dim idx As Long: idx = 1For Each a In anchorsDim picName As StringpicName = GetPicName(a)Debug.Print "[ANCHOR] name=", picName' 尝试从锚点对应的起始单元格公式中解析 ID（更可靠）Dim anchorId As StringanchorId = TryGetIdFromAnchor(ws, a)If Len(anchorId) > 0 ThenDebug.Print "[ANCHOR] id-from-cell=", anchorIdEnd If' 选择用于查找图片的键：优先使用公式ID，否则用 cNvPr nameDim lookupKey As StringIf Len(anchorId) > 0 ThenlookupKey = anchorIdElselookupKey = picNameEnd IfIf Len(lookupKey) = 0 Then GoTo NEXT_A' 优先尝试：若提供了 idFilter 但 lookupKey 不在其中，则尝试用内嵌媒体（rels→xl/media）Dim picPath As StringDim embeddedPath As StringpicPath = vbNullStringembeddedPath = ResolveEmbeddedImageFromAnchor(drawingXmlPath, a)If Not idFilter Is Nothing ThenIf Not idFilter.exists(lookupKey) ThenIf Len(embeddedPath) > 0 ThenpicPath = embeddedPathDebug.Print "[ANCHOR] use embedded for non-formula:", lookupKey, " -> ", picPathElseDebug.Print "[ANCHOR] skip not in formula:", lookupKeyGoTo NEXT_AEnd IfEnd IfEnd If' Choose source: prefer embedded for default "图片 N"/"Picture N" names to avoid wrong external matchesDim isDefaultName As BooleanisDefaultName = (InStr(1, lookupKey, "图片 ", vbTextCompare) = 1 Or InStr(1, lookupKey, "Picture ", vbTextCompare) = 1)If Len(picPath) = 0 ThenIf isDefaultName ThenIf Len(embeddedPath) > 0 ThenpicPath = embeddedPathDebug.Print "[ANCHOR] prefer embedded for default name:", lookupKey, " -> ", picPathEnd IfEnd IfEnd IfIf Len(picPath) = 0 ThenIf Len(imgFolder) > 0 And Not isDefaultName ThenpicPath = FindImageById(imgFolder, lookupKey)ElseIf Len(embeddedPath) > 0 And Len(imgFolder) = 0 ThenpicPath = embeddedPathDebug.Print "[ANCHOR] using embedded (no external folder):", lookupKey, " -> ", picPathEnd IfEnd IfIf Len(picPath) = 0 And Len(embeddedPath) > 0 ThenpicPath = embeddedPathEnd IfIf Len(picPath) = 0 ThenDebug.Print "[ANCHOR] image not found for:", lookupKeyGoTo NEXT_AEnd IfDebug.Print "[RENDER] picName=", picNameDebug.Print "[RENDER] lookupKey=", lookupKeyDebug.Print "[RENDER] picPath=", picPathDim leftPt As Double, topPt As Double, widthPt As Double, heightPt As Double, ok As Booleanok = ComputeAnchorPosition(ws, a, leftPt, topPt, widthPt, heightPt)Debug.Print "[RENDER] ok=", ok, " left=", leftPt, " top=", topPt, " w=", widthPt, " h=", heightPtIf Not ok Then GoTo NEXT_ADim shpName As StringshpName = "ANC_" & CleanKey(picName) & "_" & CStr(idx)idx = idx + 1Dim shp As ShapeSet shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, leftPt, topPt, widthPt, heightPt)shp.name = shpNameshp.LockAspectRatio = MSO_FALSE ' 按锚点尺寸shp.Placement = XL_MOVE_AND_SIZEDebug.Print "[RENDERED]", shp.name
NEXT_A:Next
End Sub' 直插图：按公式锚点直接在单元格位置插入图片（不依赖 drawings）
Private Sub RenderByFormulaDirect(ByVal ws As Worksheet, ByVal imgFolder As String)On Error Resume NextDebug.Print "[RBF-DIRECT] ws:", ws.nameIf Len(imgFolder) = 0 ThenDebug.Print "[RBF-DIRECT] skip: no external folder provided"Exit SubEnd IfDim rng As Range, c As RangeSet rng = ws.UsedRangeIf rng Is Nothing Then Exit SubDeleteShapesByPrefix ws, "ANC_"Dim f As String, id As String, modeVal As LongDim tgt As Range, shp As Shape, picPath As StringFor Each c In rng.CellsIf c.HasFormula Thenf = vbNullStringOn Error Resume Nextf = c.Formula2If Len(f) = 0 Then f = c.FormulaOn Error GoTo 0If TryParseDispImg(f, id, modeVal) ThenpicPath = FindImageById(imgFolder, id)Debug.Print "[RBF-DIRECT] cell:", ws.name, c.Address(False, False), " id=", id, " path=", picPathIf Len(picPath) > 0 ThenIf c.MergeCells Then Set tgt = c.MergeArea Else Set tgt = cSet shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, tgt.Left, tgt.Top, 10, 10)shp.LockAspectRatio = MSO_TRUEFitShapeIntoRange shp, tgtshp.Placement = XL_MOVE_AND_SIZEEnd IfEnd IfEnd IfNext
End SubPrivate Sub FitShapeIntoRange(ByVal shp As Shape, ByVal rg As Range)On Error Resume NextDim tw As Double, th As Doubletw = rg.Width: th = rg.HeightIf tw <= 0 Or th <= 0 Then Exit Subshp.LockAspectRatio = MSO_TRUEshp.Width = twIf shp.Height > th Then shp.Height = thshp.Left = rg.Left + (tw - shp.Width) / 2shp.Top = rg.Top + (th - shp.Height) / 2
End SubPrivate Sub RenderByFormulaWithEmbedded(ByVal ws As Worksheet, ByVal imgFolder As String, ByVal idFilter As Object, ByVal idEmbedded As Object)On Error Resume NextDim rng As Range, c As RangeSet rng = ws.UsedRangeIf rng Is Nothing Then Exit SubDim f As String, id As String, modeVal As LongDim tgt As Range, shp As Shape, picPath As StringFor Each c In rng.CellsIf c.HasFormula Thenf = vbNullStringOn Error Resume Nextf = c.Formula2If Len(f) = 0 Then f = c.FormulaOn Error GoTo 0If TryParseDispImg(f, id, modeVal) ThenIf Not idFilter Is Nothing ThenIf Not idFilter.exists(id) Then GoTo NEXT_CEnd IfpicPath = vbNullStringIf Len(imgFolder) > 0 ThenpicPath = FindImageById(imgFolder, id)End IfIf Len(picPath) = 0 ThenIf Not idEmbedded Is Nothing ThenIf idEmbedded.exists(id) Then picPath = CStr(idEmbedded(id))End IfEnd IfIf Len(picPath) > 0 ThenIf c.MergeCells Then Set tgt = c.MergeArea Else Set tgt = cSet shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, tgt.Left, tgt.Top, 10, 10)shp.LockAspectRatio = MSO_TRUEFitShapeIntoRange shp, tgtshp.Placement = XL_MOVE_AND_SIZEshp.name = "ANC_CELLIMG_ID_" & CleanKey(id)Debug.Print "[RENDERED-CELLIMG-FORMULA]", ws.name, c.Address(False, False), id, " -> ", picPathEnd IfEnd IfEnd If
NEXT_C:Next
End Sub' 从锚点(from 节点)对应的单元格解析公式里的 IDPrivate Function TryGetIdFromAnchor(ByVal ws As Worksheet, ByVal anchor As Object) As StringOn Error Resume NextDim fromNode As ObjectSet fromNode = anchor.SelectSingleNode(".//*[local-name()='from']")If fromNode Is Nothing Then Exit FunctionDim c As Long, r As Longc = CLng(GetChildText(fromNode, "*[local-name()='col']", 0))r = CLng(GetChildText(fromNode, "*[local-name()='row']", 0))If r < 0 Or c < 0 Then Exit FunctionDim f As String, id As String, modeVal As Longf = vbNullStringOn Error Resume Nextf = ws.Cells(r + 1, c + 1).Formula2If Len(f) = 0 Then f = ws.Cells(r + 1, c + 1).FormulaOn Error GoTo 0If TryParseDispImg(f, id, modeVal) ThenTryGetIdFromAnchor = idEnd IfEnd 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 BooleanDim fromNode As Object, toNode As Object, extNode As ObjectSet 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 DoubleDim toC As Long, toR As Long, toColOffEMU As Double, toRowOffEMU As DoublefromC = 0: fromR = 0: fromColOffEMU = 0: fromRowOffEMU = 0toC = 0: toR = 0: toColOffEMU = 0: toRowOffEMU = 0If Not fromNode Is Nothing ThenfromC = 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 IfIf Not toNode Is Nothing ThentoC = 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 IfleftPt = ws.Cells(1, fromC + 1).Left + EmuToPt(fromColOffEMU)topPt = ws.Cells(fromR + 1, 1).Top + EmuToPt(fromRowOffEMU)If Not extNode Is Nothing ThenwidthPt = EmuToPt(CDbl(GetAttr(extNode, "cx", 0#)))heightPt = EmuToPt(CDbl(GetAttr(extNode, "cy", 0#)))If widthPt <= 0 Or heightPt <= 0 ThenComputeAnchorPosition = FalseExit FunctionEnd IfElseIf Not toNode Is Nothing ThenDim rightPt As Double, bottomPt As DoublerightPt = ws.Cells(1, toC + 1).Left + EmuToPt(toColOffEMU)bottomPt = ws.Cells(toR + 1, 1).Top + EmuToPt(toRowOffEMU)widthPt = rightPt - leftPtheightPt = bottomPt - topPtIf widthPt <= 0 Or heightPt <= 0 ThenComputeAnchorPosition = FalseExit FunctionEnd IfElseComputeAnchorPosition = FalseExit FunctionEnd IfComputeAnchorPosition = True
End Function' 读取图片的 cNvPr/@name
Private Function GetPicName(ByVal anchor As Object) As StringDim n As ObjectSet n = anchor.SelectSingleNode(".//*[local-name()='cNvPr' and @name]")If n Is Nothing Then Exit FunctionOn Error Resume NextGetPicName = n.Attributes.getNamedItem("name").TextOn Error GoTo 0
End Function' 收集一个工作表中出现的 DISPIMG("ID_xxx") 的所有 ID
Private Function CollectDispImgIdsOnSheet(ByVal ws As Worksheet) As ObjectDim rng As Range, c As RangeOn Error Resume NextSet rng = ws.UsedRangeOn Error GoTo 0If rng Is Nothing Then Exit FunctionDim d As Object: Set d = CreateObject("Scripting.Dictionary")d.CompareMode = 1 ' TextCompareDim f As String, id As String, modeVal As LongFor Each c In rng.CellsIf c.HasFormula ThenOn Error Resume Nextf = c.Formula2If Len(f) = 0 Then f = c.FormulaOn Error GoTo 0Debug.Print "[FORMULA]", ws.name, c.Address(False, False), fIf TryParseDispImg(f, id, modeVal) ThenDebug.Print "[PARSED OK]", id, modeValIf Not d.exists(id) Then d.Add id, TrueElseDebug.Print "[PARSED FAIL]"End IfEnd IfNextSet CollectDispImgIdsOnSheet = d
End Function' 解析 workbook.xml，把 sheetXml -> sheetName 的映射表建立起来
Private Function MapSheetXmlToName(ByVal unzipDir As String) As ObjectOn Error GoTo FAILDim wbXml As StringwbXml = AddSlash(unzipDir) & "xl\workbook.xml"If Len(Dir$(wbXml)) = 0 Then Exit FunctionDim rels As Object ' rId -> targetSet 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 = Falsedoc.SetProperty "SelectionLanguage", "XPath"If Not doc.Load(wbXml) Then Exit FunctionDim d As Object: Set d = CreateObject("Scripting.Dictionary")d.CompareMode = 1Dim sheet As Object, rid As String, name As String, target As StringFor 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 ThenIf Not rels Is Nothing And rels.exists(rid) Thentarget = CStr(rels(rid)) ' e.g. worksheets/sheet1.xmld(target) = nameEnd IfEnd IfNextSet MapSheetXmlToName = dExit Function
FAIL:
End Function' 根据 sheet 名找回对应的 sheetXml 相对路径
Private Function FindSheetXmlByName(ByVal sheetMap As Object, ByVal sheetName As String) As StringDim k As VariantFor Each k In sheetMap.KeysIf StrComp(CStr(sheetMap(k)), sheetName, vbTextCompare) = 0 ThenFindSheetXmlByName = CStr(k)Exit FunctionEnd IfNext
End Function' 读取 xl/worksheets/_rels/sheetX.xml.rels 里的 drawing 目标
Private Function FindSheetDrawingTarget(ByVal unzipDir As String, ByVal sheetTarget As String) As StringDim relPath As StringrelPath = AddSlash(unzipDir) & "xl\" & GetParentFolder(sheetTarget) & "_rels\" & GetFileName(sheetTarget) & ".rels"Dim rels As ObjectSet rels = LoadRels(relPath, "http://schemas.openxmlformats.org/officeDocument/2006/relationships/drawing")If rels Is Nothing Then Exit FunctionDim k As VariantFor Each k In rels.KeysFindSheetDrawingTarget = CStr(rels(k)) ' e.g. ../drawings/drawing1.xmlExit FunctionNext
End Function' 加载 .rels (可选过滤 Type)，返回 rId -> Target
Private Function LoadRels(ByVal relsPath As String, ByVal typeFilter As String) As ObjectIf Len(Dir$(relsPath)) = 0 ThenDebug.Print "[RELS] missing", relsPathExit FunctionEnd IfDim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")doc.async = False: doc.validateOnParse = Falsedoc.SetProperty "SelectionLanguage", "XPath"If Not doc.Load(relsPath) ThenDebug.Print "[RELS] load fail", relsPathExit FunctionEnd IfDim d As Object: Set d = CreateObject("Scripting.Dictionary")d.CompareMode = 1Dim rel As Object, id As String, target As String, typ As StringFor 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 ThenIf Len(typeFilter) = 0 Or StrComp(typ, typeFilter, vbTextCompare) = 0 Thend(id) = targetEnd IfEnd IfNextDebug.Print "[RELS] loaded", relsPath, " count=", d.CountSet LoadRels = d
End Function' 读取 cellimages.xml.rels 中 rid -> name（DISPIMG第一个参数）的映射（WPS常见扩展）
Private Function LoadCellImageRidToNameMap(ByVal relsPath As String) As ObjectOn Error GoTo FAILIf Len(Dir$(relsPath)) = 0 Then Exit FunctionDim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")doc.async = False: doc.validateOnParse = Falsedoc.SetProperty "SelectionLanguage", "XPath"If Not doc.Load(relsPath) Then Exit FunctionDim d As Object: Set d = CreateObject("Scripting.Dictionary")d.CompareMode = 1Dim rel As Object, rid As String, nm As StringFor 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 Thend(rid) = nmEnd IfNextSet LoadCellImageRidToNameMap = dExit Function
FAIL:
End Function' =============== 公式清理功能 ===============' 删除当前活动工作表中的所有 DISPIMG 公式（将单元格置为空文本，保留格式与已插入的图片）
Public Sub DISPIMG_DeleteFormulas_CurrentSheet()On Error Resume NextDeleteDispImgFormulasOnSheet ActiveSheet, ""
End Sub' 删除整个工作簿中所有工作表的 DISPIMG 公式
Public Sub DISPIMG_DeleteFormulas_AllSheets()Dim ws As WorksheetFor Each ws In ActiveWorkbook.WorksheetsDeleteDispImgFormulasOnSheet ws, ""NextMsgBox "已删除所有工作表中的 DISPIMG 公式。", vbInformation
End Sub' 核心：删除指定工作表中的 DISPIMG 公式
' replacementText 用于写入替换文本，通常为空字符串
Private Sub DeleteDispImgFormulasOnSheet(ByVal ws As Worksheet, ByVal replacementText As String)On Error Resume NextDim rng As Range, c As RangeSet rng = ws.UsedRangeIf rng Is Nothing Then Exit SubDim f As String, id As String, modeVal As LongDim cnt As LongFor Each c In rng.CellsIf c.HasFormula Thenf = vbNullStringOn Error Resume Nextf = c.Formula2If Len(f) = 0 Then f = c.FormulaOn Error GoTo 0If TryParseDispImg(f, id, modeVal) Thenc.Formula = vbNullStringc.Value = replacementTextcnt = cnt + 1Debug.Print "[DELETE-DISPIMG]", ws.name, c.Address(False, False), fEnd IfEnd IfNextDebug.Print "[DELETE-DISPIMG] sheet=", ws.name, " removed=", cnt
End Sub' =============== 工具函数 ===============Private Function EmuToPt(ByVal emu As Double) As DoubleEmuToPt = emu / 12700#
End FunctionPrivate Function GetChildText(ByVal parent As Object, ByVal xpath As String, ByVal def As Variant) As VariantDim n As ObjectSet n = parent.SelectSingleNode(xpath)If n Is Nothing ThenGetChildText = defElseGetChildText = n.TextEnd If
End FunctionPrivate Function GetAttr(ByVal n As Object, ByVal attrName As String, ByVal def As String) As StringOn Error Resume NextDim a As ObjectSet a = n.Attributes.getNamedItem(attrName)If a Is Nothing ThenGetAttr = defElseGetAttr = a.TextEnd If
End FunctionPrivate Function GetAttrNs(ByVal n As Object, ByVal localName As String, ByVal nsUri As String, ByVal def As String) As StringOn Error Resume NextDim a As Object, i As LongFor i = 0 To n.Attributes.Length - 1Set a = n.Attributes.Item(i)If Not a Is Nothing ThenIf InStr(1, a.nodeName, ":" & localName, vbTextCompare) > 0 ThenIf CStr(a.NamespaceURI) = nsUri ThenGetAttrNs = a.TextExit FunctionEnd IfEnd IfEnd IfNextGetAttrNs = def
End FunctionPrivate Sub DeleteShapesByPrefix(ByVal ws As Worksheet, ByVal prefix As String)Dim i As LongFor i = ws.Shapes.Count To 1 Step -1If Left$(ws.Shapes(i).name, Len(prefix)) = prefix ThenOn Error Resume Nextws.Shapes(i).DeleteOn Error GoTo 0End IfNext
End SubPrivate Function CleanKey(ByVal s As String) As StringDim t As Stringt = st = 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 BooleanOn Error GoTo FAILDebug.Print "[UNZIP] start wb=", wbPath, " dest=", destDirDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")If Not fso.FolderExists(destDir) Then fso.CreateFolder destDirDim zipPath As String: zipPath = AddSlash(destDir) & "src.zip"Debug.Print "[UNZIP] zipPath=", zipPathOn Error Resume Nextfso.CopyFile wbPath, zipPath, TrueIf Err.Number <> 0 ThenDebug.Print "[UNZIP] CopyFile err=", Err.Number, Err.DescriptionErr.ClearEnd IfOn Error GoTo FAILIf Len(Dir$(zipPath)) = 0 ThenDebug.Print "[UNZIP] zip not created, fallback to PS"If UnzipWithPowerShellLocal(wbPath, destDir) ThenUnzipWorkbookToFolder = TrueExit FunctionElseGoTo FAILEnd IfEnd IfDim sh As Object: Set sh = CreateObject("Shell.Application")Dim src As Object, dst As ObjectSet 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 ThenDebug.Print "[UNZIP] shell unzip not available, try PS"If UnzipWithPowerShellLocal(zipPath, destDir) ThenUnzipWorkbookToFolder = TrueExit FunctionElseGoTo FAILEnd IfEnd IfDebug.Print "[UNZIP] CopyHere items=", src.items.CountConst FOF_SILENT As Long = 4Const FOF_NOCONFIRMATION As Long = 16Const FOF_NOCONFIRMMKDIR As Long = 512Const FOF_NOERRORUI As Long = 1024dst.CopyHere src.items, FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOCONFIRMMKDIR Or FOF_NOERRORUI' 等待关键文件出现，最多 8 秒Dim t As Single: t = TimerDo While Len(Dir$(AddSlash(destDir) & "xl\workbook.xml")) = 0 And (Timer - t < 8)DoEventsLoopDim exists As Booleanexists = (Len(Dir$(AddSlash(destDir) & "xl\workbook.xml")) > 0)Debug.Print "[UNZIP] workbook.xml exists=", exists, " elapsed=", (Timer - t)If Not exists ThenDebug.Print "[UNZIP] shell unzip not yielding files, try PS"If UnzipWithPowerShellLocal(zipPath, destDir) ThenUnzipWorkbookToFolder = TrueExit FunctionElseGoTo FAILEnd IfEnd IfUnzipWorkbookToFolder = TrueExit Function
FAIL:Debug.Print "[UNZIP] FAIL Err=", Err.Number, " Desc=", Err.DescriptionUnzipWorkbookToFolder = False
End FunctionPrivate Function UnzipWithPowerShellLocal(ByVal zipFilePath As String, ByVal destinationPath As String) As BooleanOn Error GoTo EHDim wsh As Object: Set wsh = CreateObject("WScript.Shell")Dim quotedZip As String, quotedDest As StringquotedZip = PSQuoteLocal(zipFilePath)quotedDest = PSQuoteLocal(destinationPath)Dim cmd As Stringcmd = "powershell -NoProfile -NonInteractive -ExecutionPolicy Bypass -Command " & _"Try { Expand-Archive -LiteralPath " & quotedZip & " -DestinationPath " & quotedDest & " -Force; exit 0 } Catch { exit 1 }"Dim rc As Longrc = wsh.Run(cmd, 0, True) ' waitIf rc = 0 Then' verify resultUnzipWithPowerShellLocal = (Len(Dir$(AddSlash(destinationPath) & "xl\workbook.xml")) > 0)ElseUnzipWithPowerShellLocal = FalseEnd IfExit Function
EH:UnzipWithPowerShellLocal = False
End FunctionPrivate Function ResolveEmbeddedImageFromAnchor(ByVal drawingXmlPath As String, ByVal anchor As Object) As StringOn Error GoTo FAIL' 1) 从 anchor 内找到 a:blip 的 embed/link（不依赖命名空间前缀）Dim blip As ObjectSet blip = anchor.SelectSingleNode(".//*[local-name()='blip' and @*[local-name()='embed']]")If blip Is Nothing ThenSet blip = anchor.SelectSingleNode(".//*[local-name()='blip' and @*[local-name()='link']]")End IfIf blip Is Nothing Then Exit FunctionDim rid As Stringrid = GetAttrNs(blip, "embed", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")If Len(rid) = 0 Thenrid = GetAttrNs(blip, "link", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")End IfIf Len(rid) = 0 Then Exit Function' 2) 打开 drawing.xml.rels，找到 rId 对应的 TargetDim relsPath As StringrelsPath = Left$(drawingXmlPath, InStrRev(drawingXmlPath, "\")) & "_rels\" & Mid$(drawingXmlPath, InStrRev(drawingXmlPath, "\") + 1) & ".rels"Dim rels As ObjectSet rels = LoadRels(relsPath, "")If rels Is Nothing Then Exit FunctionDim target As StringIf Not rels.exists(rid) Then Exit Functiontarget = CStr(rels(rid)) ' e.g. ../media/image1.png 或 media/image1.png' 3) 解析真实路径，优先返回解压目录里的文件路径Dim baseDir As StringbaseDir = Left$(drawingXmlPath, InStrRev(drawingXmlPath, "\") - 1) ' ...\xl\drawingsDim unzipRoot As StringunzipRoot = Left$(baseDir, InStrRev(baseDir, "\") - 1) ' ...\xlDim mediaPath As StringIf InStr(1, target, "../", vbTextCompare) > 0 ThenmediaPath = unzipRoot & "\" & Replace(target, "../", "")ElsemediaPath = baseDir & "\" & targetEnd IfmediaPath = NormalizePath(mediaPath)If Len(Dir$(mediaPath)) > 0 Then ResolveEmbeddedImageFromAnchor = mediaPathExit Function
FAIL:
End FunctionPrivate Function PSQuoteLocal(ByVal s As String) As StringPSQuoteLocal = "'" & Replace(s, "'", "''") & "'"
End Function' 创建临时目录（root 为空则用可写的临时目录，含多级回退）
Private Function CreateTempFolder(ByVal root As String) As StringOn Error GoTo FAILDim 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' 回退到桌面/TempOn Error Resume Nextcandidates.Add CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Temp"On Error GoTo 0' 最后回退 C:\Temp（若有权限）candidates.Add "C:\Temp"Dim base As String, testPath As StringDim c As VariantFor Each c In candidatesbase = CStr(c)If Len(base) = 0 Then GoTo NEXT_BASEDebug.Print "[TMP] try base=", baseIf EnsureFolderLocal(base) Then' 写入测试testPath = AddSlash(base) & "perm_test_" & Format(Now, "yyyymmddhhnnss") & "_" & CLng(Rnd() * 100000)On Error Resume Nextfso.CreateFolder testPathIf Err.Number = 0 Thenfso.DeleteFolder testPath, TrueOn Error GoTo 0Exit ForEnd IfDebug.Print "[TMP] base not writable, err=", Err.Number, Err.DescriptionErr.ClearOn Error GoTo 0End If
NEXT_BASE:NextIf Len(base) = 0 Then GoTo FAIL' 创建唯一子目录Dim i As Long, p As StringFor i = 1 To 5p = AddSlash(base) & "xl_temp_" & Format(Now, "yyyymmddhhnnss") & "_" & CLng(Rnd() * 1000000)On Error Resume Nextfso.CreateFolder pIf Err.Number = 0 ThenOn Error GoTo 0Debug.Print "[TMP] created=", pCreateTempFolder = pExit FunctionEnd IfDebug.Print "[TMP] create fail err=", Err.Number, Err.DescriptionErr.ClearOn Error GoTo 0NextFAIL:Debug.Print "[TMP] CreateTempFolder FAIL err=", Err.Number, Err.DescriptionCreateTempFolder = ""
End Function' 递归确保目录存在
Private Function EnsureFolderLocal(ByVal folderPath As String) As BooleanOn Error Resume NextDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")If fso.FolderExists(folderPath) Then EnsureFolderLocal = True: Exit FunctionDim parent As String: parent = fso.GetParentFolderName(folderPath)If Len(parent) > 0 ThenIf Not fso.FolderExists(parent) ThenIf Not EnsureFolderLocal(parent) Then Exit FunctionEnd IfEnd IfDim fld As Object: Set fld = fso.CreateFolder(folderPath)EnsureFolderLocal = Not fld Is Nothing
End FunctionPrivate Sub DeleteFolderSilent(ByVal p As String)On Error Resume NextDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")If fso.FolderExists(p) Then fso.DeleteFolder p, True
End SubPrivate Function AddSlash(ByVal p As String) As StringIf Right$(p, 1) = "\" Or Right$(p, 1) = "/" Then AddSlash = p Else AddSlash = p & "\"
End FunctionPrivate Function NormalizePath(ByVal p As String) As StringNormalizePath = Replace(p, "/", "\")
End FunctionPrivate Function GetParentFolder(ByVal rel As String) As StringDim i As Longi = InStrRev(rel, "/")If i = 0 ThenGetParentFolder = ""ElseGetParentFolder = Left$(rel, i)End If
End FunctionPrivate Function GetFileName(ByVal rel As String) As StringDim i As Longi = InStrRev(rel, "/")If i = 0 ThenGetFileName = relElseGetFileName = 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 BooleanDim sRow As String, sCol As String, ref As String' 1) row/col attributessRow = GetAttr(it, "row", "")sCol = GetAttr(it, "col", "")If Len(sRow) > 0 And Len(sCol) > 0 Thenr = CLng(sRow)c = CLng(sCol)TryGetCellImageRowCol = TrueExit FunctionEnd If' 2) r/c attributes (WPS variants)sRow = GetAttr(it, "r", "")sCol = GetAttr(it, "c", "")If Len(sRow) > 0 And Len(sCol) > 0 Thenr = CLng(sRow)c = CLng(sCol)TryGetCellImageRowCol = TrueExit FunctionEnd If' 3) child nodes <row>/<col> directly under itemOn Error Resume NextsRow = vbNullString: sCol = vbNullStringDim rn As Object, cn As ObjectSet rn = it.SelectSingleNode("./*[local-name()='row']")Set cn = it.SelectSingleNode("./*[local-name()='col']")If Not rn Is Nothing Then sRow = rn.TextIf Not cn Is Nothing Then sCol = cn.TextOn Error GoTo 0If Len(sRow) > 0 And Len(sCol) > 0 Thenr = CLng(sRow)c = CLng(sCol)TryGetCellImageRowCol = TrueExit FunctionEnd If' 3b) nested from node (e.g., .//*[local-name()='anchor']/*[local-name()='from'])Dim fromN As Object, rowN As Object, colN As ObjectSet fromN = it.SelectSingleNode(".//*[local-name()='from']")If Not fromN Is Nothing ThensRow = vbNullString: sCol = vbNullStringSet rowN = fromN.SelectSingleNode("./*[local-name()='row']")Set colN = fromN.SelectSingleNode("./*[local-name()='col']")If Not rowN Is Nothing Then sRow = rowN.TextIf Not colN Is Nothing Then sCol = colN.Text' some variants store as attributes on fromIf 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 Thenr = CLng(sRow)c = CLng(sCol)TryGetCellImageRowCol = TrueExit FunctionEnd IfEnd If' 4) ref-like attributes (namespaced): @ref / @cell / @sqref (take first A1)On Error Resume NextDim attrRef As ObjectSet attrRef = it.SelectSingleNode("@*[local-name()='ref' or local-name()='cell' or local-name()='sqref']")On Error GoTo 0If Not attrRef Is Nothing Thenref = CStr(attrRef.Text)If Len(ref) > 0 ThenDim a1 As String, p As Longp = InStr(1, ref, ":", vbTextCompare)If p > 0 Then a1 = Left$(ref, p - 1) Else a1 = refIf TryParseA1Ref(a1, r, c) ThenTryGetCellImageRowCol = TrueExit FunctionEnd IfEnd IfEnd If' 4b) plain ref attribute (non-namespaced)ref = GetAttr(it, "ref", "")If Len(ref) > 0 ThenDim a1x As String, px As Longpx = InStr(1, ref, ":", vbTextCompare)If px > 0 Then a1x = Left$(ref, px - 1) Else a1x = refIf TryParseA1Ref(a1x, r, c) ThenTryGetCellImageRowCol = TrueExit FunctionEnd IfEnd IfTryGetCellImageRowCol = 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 BooleanDim s As String: s = UCase$(Trim$(a1))If Len(s) = 0 Then Exit FunctionDim i As Long, letters As String, digits As String, ch As StringFor i = 1 To Len(s)ch = Mid$(s, i, 1)If ch >= "A" And ch <= "Z" Thenletters = letters & chElseIf ch >= "0" And ch <= "9" Thendigits = Mid$(s, i)Exit ForElseExit FunctionEnd IfNextIf Len(letters) = 0 Or Len(digits) = 0 Then Exit FunctionDim colIndex As Long: colIndex = ColLettersToIndex(letters)If colIndex <= 0 Then Exit Functionr = CLng(digits) - 1c = colIndex - 1TryParseA1Ref = (r >= 0 And c >= 0)
End FunctionPrivate Function ColLettersToIndex(ByVal letters As String) As LongDim i As Long, v As Long, ch As StringFor i = 1 To Len(letters)ch = Mid$(letters, i, 1)If ch < "A" Or ch > "Z" Then Exit Functionv = v * 26 + (Asc(ch) - Asc("A") + 1)NextColLettersToIndex = v
End Function' 在目录中查找图片文件（支持中文名称和ID命名）
Private Function FindImageById(ByVal folder As String, ByVal imgId As String) As StringDebug.Print "[FINDIMG] Looking for:", imgId, " in folder:", folder' 首先尝试直接匹配文件名（支持中文名称如"图片 1"）Dim extArr, i As Long, tryPath As StringextArr = 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 ThenDebug.Print "[FINDIMG] Found direct match:", tryPathFindImageById = tryPathExit FunctionEnd IfNext' 如果直接匹配失败，尝试通配符搜索Dim f As StringDim wildcardPattern As StringwildcardPattern = AddSlash(folder) & imgId & ".*"Debug.Print "[FINDIMG] Trying wildcard:", wildcardPatternf = Dir$(wildcardPattern)Debug.Print "[FINDIMG] Wildcard result:", fIf Len(f) > 0 ThenDim resultPath As StringresultPath = AddSlash(folder) & fDebug.Print "[FINDIMG] Found wildcard match:", resultPathFindImageById = resultPathExit FunctionEnd IfDebug.Print "[FINDIMG] No match found for:", imgIdFindImageById = ""
End Function' 解析公式文本中的 DISPIMG("ID_...")
Private Function TryParseDispImg(ByVal formulaText As String, ByRef outId As String, ByRef outMode As Long) As BooleanDim re As Object: Set re = CreateObject("VBScript.RegExp")re.Global = Falsere.IgnoreCase = Truere.Pattern = "(@_?xlfn\.)?DISPIMG\s*\(\s*""(ID_?[A-F0-9]{32})""\s*(,\s*([0-9]+))?"Dim m As ObjectIf re.Test(formulaText) ThenSet m = re.Execute(formulaText)outId = m(0).SubMatches(1)If m(0).SubMatches.Count >= 4 And Len(m(0).SubMatches(3)) > 0 ThenoutMode = CLng(m(0).SubMatches(3))ElseoutMode = 1End IfTryParseDispImg = TrueElseTryParseDispImg = FalseEnd If
End Function' 选择文件夹对话框
Private Function PickFolder(ByVal title As String) As StringOn Error Resume NextWith Application.FileDialog(msoFileDialogFolderPicker).title = titleIf .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 StringDim relPath As StringrelPath = AddSlash(unzipDir) & "xl\" & GetParentFolder(sheetTarget) & "_rels\" & GetFileName(sheetTarget) & ".rels"Dim rels As ObjectSet rels = LoadRels(relPath, "")If rels Is Nothing Then Exit FunctionDim k As Variant, target As StringFor Each k In rels.Keystarget = CStr(rels(k))If InStr(1, target, "cellimage", vbTextCompare) > 0 Or InStr(1, target, "cellimages", vbTextCompare) > 0 ThenFindSheetCellImagesTarget = target ' e.g. ../cellimages/cellimages.xmlExit FunctionEnd IfNext
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_SUBDim cellTarget As StringcellTarget = FindSheetCellImagesTarget(unzipDir, sheetTarget)Dim cellXml As StringIf Len(cellTarget) > 0 ThencellXml = NormalizePath(AddSlash(unzipDir) & "xl\" & Replace(cellTarget, "../", ""))Else' WPS fallback: try workbook-level cellimages partsDim cand1 As String, cand2 As Stringcand1 = NormalizePath(AddSlash(unzipDir) & "xl\cellimages.xml")cand2 = NormalizePath(AddSlash(unzipDir) & "xl\cellimages\cellimages.xml")If Len(Dir$(cand1)) > 0 ThencellXml = cand1ElseIf Len(Dir$(cand2)) > 0 ThencellXml = cand2ElseDebug.Print "[CELLIMG] not found under xl: cellimages.xml or cellimages\cellimages.xml"GoTo EXIT_SUBEnd IfEnd IfDebug.Print "[CELLIMG] cellXml=", cellXmlIf Len(Dir$(cellXml)) = 0 Then GoTo EXIT_SUBDim doc As Object: Set doc = CreateObject("MSXML2.DOMDocument.6.0")doc.async = False: doc.validateOnParse = Falsedoc.SetProperty "SelectionLanguage", "XPath"If Not doc.Load(cellXml) Then Exit SubDim relsPath As StringrelsPath = Left$(cellXml, InStrRev(cellXml, "\")) & "_rels\" & Mid$(cellXml, InStrRev(cellXml, "\") + 1) & ".rels"Dim rels As ObjectSet rels = LoadRels(relsPath, "")If rels Is Nothing Then Exit SubDim ridToName As ObjectSet ridToName = LoadCellImageRidToNameMap(relsPath)Dim items As Object, it As ObjectSet items = doc.SelectNodes("//*[local-name()='cellImage']")On Error Resume NextDebug.Print "[CELLIMG] items count=", items.LengthOn Error GoTo 0Dim r As Long, c As LongDim rid As String, target As String, mediaPath As StringDim rowAttr As String, colAttr As StringDim unzipRoot As String, baseDir As StringbaseDir = Left$(cellXml, InStrRev(cellXml, "\") - 1) ' ...\xl\cellimagesunzipRoot = 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 ObjectSet idEmbedded = CreateObject("Scripting.Dictionary")idEmbedded.CompareMode = 1Dim it2 As Object, nameN As Object, blN As ObjectDim rid2 As String, idKey As String, target2 As String, mediaPath2 As StringFor Each it2 In itemsSet nameN = it2.SelectSingleNode(".//*[local-name()='cNvPr']")idKey = ""If Not nameN Is Nothing ThenidKey = GetAttr(nameN, "name", "")If Len(idKey) > 0 And InStr(1, idKey, "ID_", vbTextCompare) = 1 ThenSet blN = it2.SelectSingleNode(".//*[local-name()='blip']")rid2 = vbNullStringIf Not blN Is Nothing Thenrid2 = GetAttrNs(blN, "embed", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")If Len(rid2) = 0 Thenrid2 = GetAttrNs(blN, "link", "http://schemas.openxmlformats.org/officeDocument/2006/relationships", "")End IfEnd IfIf Len(rid2) > 0 ThenIf rels.exists(rid2) Thentarget2 = CStr(rels(rid2))If InStr(1, target2, "../", vbTextCompare) > 0 ThenmediaPath2 = unzipRoot & "\" & Replace(target2, "../", "")ElsemediaPath2 = baseDir & "\" & target2End IfmediaPath2 = NormalizePath(mediaPath2)If Len(Dir$(mediaPath2)) > 0 ThenIf Not idEmbedded.exists(idKey) Then idEmbedded.Add idKey, mediaPath2Debug.Print "[CELLIMG] map ID->embedded:", idKey, " -> ", mediaPath2End IfEnd IfEnd IfEnd IfEnd IfNext' WPS policy: avoid using row/col from cellimages.xml; always render by formula + ID/embedded mapRenderByFormulaWithEmbedded ws, imgFolder, idFilter, idEmbeddedGoTo EXIT_SUBDim renderedCount As LongrenderedCount = 0Dim shp As Shape, tgt As Range, f As String, id As String, modeVal As LongDim picPath As StringFor Each it In itemsIf Not TryGetCellImageRowCol(it, r, c) ThenDebug.Print "[CELLIMG] skip: no row/col for item"GoTo NEXT_ITEnd If' Determine effective cell coordinates:' default assume zero-based -> Excel row/col = r+1, c+1Dim rr As Long, cc As Long, usedOneBased As Booleanrr = r + 1: cc = c + 1: usedOneBased = False' Optional formula filter (try zero-based first)id = vbNullString: f = vbNullString: modeVal = 0If Not idFilter Is Nothing ThenOn Error Resume Nextf = ws.Cells(rr, cc).Formula2If Len(f) = 0 Then f = ws.Cells(rr, cc).FormulaOn Error GoTo 0If Not TryParseDispImg(f, id, modeVal) Then' WPS may store 1-based row/col; try r,c directlyIf r >= 1 And c >= 1 ThenDim f2 As StringOn Error Resume Nextf2 = ws.Cells(r, c).Formula2If Len(f2) = 0 Then f2 = ws.Cells(r, c).FormulaOn Error GoTo 0If TryParseDispImg(f2, id, modeVal) Thenrr = r: cc = cusedOneBased = Truef = f2ElseGoTo NEXT_ITEnd IfElseGoTo NEXT_ITEnd IfEnd IfIf Not idFilter.exists(id) Then GoTo NEXT_ITEnd IfDebug.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 ThenDim bl As ObjectSet 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 ThenSet 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 IfEnd IfIf Len(rid) = 0 Then GoTo NEXT_ITIf Not rels.exists(rid) ThenDebug.Print "[CELLIMG] rid not in rels:", rid, " relsPath=", relsPathGoTo NEXT_ITEnd Iftarget = CStr(rels(rid)) ' ../media/imageN.png 或 media/imageN.pngDebug.Print "[CELLIMG] rid=", rid, " target=", target' 若单元格未能解析出ID，则通过 rels 的 name 属性反查 DISPIMG 第1参数If Len(id) = 0 ThenIf Not ridToName Is Nothing ThenIf ridToName.exists(rid) Thenid = CStr(ridToName(rid))End IfEnd IfEnd IfIf Len(id) > 0 ThenDebug.Print "[CELLIMG] rid name(id)=", idEnd IfIf InStr(1, target, "../", vbTextCompare) > 0 ThenmediaPath = unzipRoot & "\" & Replace(target, "../", "")ElsemediaPath = baseDir & "\" & targetEnd IfmediaPath = NormalizePath(mediaPath)' External priority (by ID) else fallback to embeddedpicPath = vbNullStringIf Len(imgFolder) > 0 And Len(id) > 0 ThenpicPath = FindImageById(imgFolder, id)End IfIf Len(picPath) = 0 And Len(Dir$(mediaPath)) > 0 ThenpicPath = mediaPathDebug.Print "[CELLIMG] using embedded:", ws.name, " R", rr, "C", cc, " -> ", picPathEnd IfIf Len(picPath) = 0 Then GoTo NEXT_IT' Insert and fitIf ws.Cells(rr, cc).MergeCells ThenSet tgt = ws.Cells(rr, cc).MergeAreaElseSet tgt = ws.Cells(rr, cc)End IfSet shp = ws.Shapes.AddPicture(picPath, MSO_FALSE, MSO_TRUE, tgt.Left, tgt.Top, 10, 10)shp.LockAspectRatio = MSO_TRUEFitShapeIntoRange shp, tgtshp.Placement = XL_MOVE_AND_SIZEshp.name = "ANC_CELLIMG_R" & (r + 1) & "C" & (c + 1)renderedCount = renderedCount + 1Debug.Print "[RENDERED-CELLIMG]", shp.nameNEXT_IT:NextIf renderedCount = 0 ThenDebug.Print "[CELLIMG] no positioned items rendered; fallback by formula with embedded map"RenderByFormulaWithEmbedded ws, imgFolder, idFilter, idEmbeddedEnd IfEXIT_SUB:
End Sub
``