从Excel批注提取原始图片及相关问题的技术求助

一、修复批注图片比例失调 #

• 核心思路：提前记录原始图片的宽高比与路径，在行/列调整后自动按原比例重置批注图片尺寸，无需重新读取原始文件
• 实现方案：
  1. 插入图片到批注时，同步记录图片的宽高比与原始路径到工作表的隐藏列（例如第24列，即X列）：

  Sub InsertPicToComment(targetRng As Range, picFullPath As String)
      Dim originalPic As StdPicture
      Set originalPic = LoadPicture(picFullPath)
      
      '添加批注并插入图片
      If targetRng.Comment Is Nothing Then targetRng.AddComment
      With targetRng.Comment.Shape
          .Fill.UserPicture picFullPath
          .LockAspectRatio = msoTrue
          '设置初始显示尺寸，按原比例计算
          .Width = 120
          .Height = 120 / (originalPic.Width / originalPic.Height)
      End With
      
      '记录路径与宽高比到隐藏列
      targetRng.Parent.Cells(targetRng.Row, 24).Value = picFullPath & "|" & originalPic.Width / originalPic.Height
  End Sub
  

  2. 给工作表添加行/列调整的监听事件，触发自动修复：

  Private Sub Worksheet_Change(ByVal Target As Range)
      '检测是否有行高/列宽调整
      If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then
          Call FixCommentImageRatios(Me)
      End If
  End Sub
  
  Sub FixCommentImageRatios(ws As Worksheet)
      Dim cmt As Comment
      Dim imgData As Variant
      For Each cmt In ws.Comments
          imgData = Split(ws.Cells(cmt.TopLeftCell.Row, 24).Value, "|")
          If UBound(imgData) = 1 Then
              With cmt.Shape
                  .LockAspectRatio = msoTrue
                  .Height = .Width / CDbl(imgData(1)) '按原比例修正高度
              End With
          End If
      Next cmt
  End Sub
  

二、提取原始画质图片 #

• 核心思路：直接调用之前记录的原始图片路径，批量复制文件到指定目录，避开HTML导出的局限性
• 实现代码：

  Sub ExtractOriginalPictures()
      Dim saveFolder As String
      Dim ws As Worksheet
      Dim lastRow As Long
      Dim i As Long
      Dim picPath As String
      Dim fileNameExt As String
      
      '设置保存路径（当前工作簿所在文件夹下的ExtractedPics文件夹）
      saveFolder = ThisWorkbook.Path & "\ExtractedPics\"
      If Dir(saveFolder, vbDirectory) = "" Then MkDir saveFolder
      
      Set ws = ThisWorkbook.Sheets("项目进度表") '替换为你的工作表名称
      lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row '假设A列为项目名称列
      
      For i = 2 To lastRow '跳过表头行
          picPath = Split(ws.Cells(i, 24).Value, "|")(0)
          If Dir(picPath) <> "" Then
              '提取文件扩展名
              fileNameExt = Right(picPath, Len(picPath) - InStrRev(picPath, "."))
              '复制文件，用项目名称命名
              FileCopy picPath, saveFolder & ws.Cells(i, 1).Value & "." & fileNameExt
          End If
      Next i
  End Sub
  

• 注意事项：如果之前未记录原始图片路径，需要先运行一次批量读取批注图片原始路径的宏（可通过遍历批注的Fill.UserPicture属性获取路径，部分版本Excel可能需要特殊处理），之后再执行提取操作。

内容的提问来源于stack exchange，提问作者seedorfj