Excel图片批量插入与文件瘦身

功能概述

定义宏功能：VBA宏实现图片路径获取、插入与压缩
应用场景：适用于批量处理文档或报表中的图片

技术实现分解

图片路径获取

使用FileDialog对象选择图片文件
遍历文件夹获取多张图片路径的方法
路径存储：数组或集合数据结构

图片插入逻辑

调用Shapes.AddPicture方法插入图片到文档
参数详解：路径、链接方式、位置、尺寸
动态调整图片位置与排版

图片压缩技术

压缩算法选择：分辨率调整或格式转换
调用PictureFormat.Compress方法
参数设置：压缩质量（如msoCompressPPT）

代码示例与注释

vba 复制代码

Sub GetPicPath_Insert_Compress()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .AllowMultiSelect = True
        .Filters.Add "Images", "*.jpg;*.png"
        If .Show = -1 Then
            For Each picPath In .SelectedItems
                ' 插入图片并压缩
                Dim shp As Shape
                Set shp = ActiveSheet.Shapes.AddPicture( _
                    picPath, False, True, 10, 10, 200, 150)
                shp.PictureFormat.Compress msoCompressPPT
            Next
        End If
    End With
End Sub

优化与扩展

错误处理：路径无效或格式错误的捕获
性能优化：批量处理时的延迟问题
扩展功能：支持更多图片格式或自定义压缩比

常见问题与解决

权限问题：文件访问权限导致的运行时错误
兼容性：不同Office版本的方法差异
资源释放：对象变量的显式释放

应用案例

自动化报告生成中的图片处理

数据库导出图片的快速嵌入与优化

Sub GetPicPath_Insert_Compress()
Dim filePath As String, picName As String
Dim targetCol As Integer, lastRow As Integer, j As Integer
Dim ws As Worksheet, fso As Object, folder As Object, file As Object
Dim picFiles As Collection, tempFile As Object
Dim compressOpt As VbMsgBoxResult

复制代码

  '1.选择目标工作表与列
  Set ws = ActiveSheet
  On Error Resume Next
  targetCol = InputBox("请输入路径录入列号（A=1，B=2...）：", "选择列号", 1)
  On Error GoTo 0
  If targetCol < 1 Or targetCol > 256 Then
      MsgBox "列号错误！请输入1-256", vbExclamation: Exit Sub
  End If
  
  '2.选择图片文件夹
  With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "选择图片文件夹"
      If .Show <> -1 Then MsgBox "未选文件夹，退出！": Exit Sub
      filePath = .SelectedItems(1) & "\"
  End With
  
  '3.筛选图片文件（支持常见格式）
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set folder = fso.GetFolder(filePath)
  Set picFiles = New Collection
  For Each file In folder.Files
      Select Case LCase(Right(file.Name, 4))
          Case ".jpg", ".jpeg", ".png", ".bmp", ".gif"
              picFiles.Add file
      End Select
  Next
  If picFiles.Count = 0 Then MsgBox "无图片文件！": Exit Sub
  
  '4.按生成时间升序排序
  For j = 1 To picFiles.Count - 1
      For i = j + 1 To picFiles.Count
          If picFiles(j).DateCreated > picFiles(i).DateCreated Then
              Set tempFile = picFiles(j)
              Set picFiles(j) = picFiles(i)
              Set picFiles(i) = tempFile
          End If
      Next
  Next
  
  '5.清空目标列内容
  ws.Columns(targetCol).ClearContents
  ws.Columns(targetCol + 1).ClearContents
  
  '6.录入路径+插入图片（用原生方法替代eh_image，确保可压缩）
  lastRow = 1
  Application.ScreenUpdating = False '关闭屏幕刷新，加速执行
  For Each file In picFiles
      '录入路径
      ws.Cells(lastRow, targetCol).Value = file.Path
      '插入图片到后一列，随单元格自适应
      With ws.Shapes.AddPicture( _
          Filename:=file.Path, LinkToFile:=False, SaveWithDocument:=True, _
          Left:=ws.Cells(lastRow, targetCol + 1).Left, Top:=ws.Cells(lastRow, targetCol + 1).Top, _
          Width:=ws.Cells(lastRow, targetCol + 1).Width, Height:=ws.Cells(lastRow, targetCol + 1).Height)
          .LockAspectRatio = msoFalse '取消比例锁定，随单元格缩放
          .Top = ws.Cells(lastRow, targetCol + 1).Top
          .Left = ws.Cells(lastRow, targetCol + 1).Left
          ws.Cells(lastRow, targetCol + 1).RowHeight = .Height '适配行高
      End With
      lastRow = lastRow + 1
  Next
  Application.ScreenUpdating = True
  
  '7.图片压缩选项
  compressOpt = MsgBox("是否执行图片压缩（降低分辨率+删除裁剪区域）？", vbYesNo + vbQuestion)
  If compressOpt = vbYes Then
      Application.ScreenUpdating = False
      '设置Excel全局图像质量：150ppi+放弃编辑数据
      With ws.Parent.Workbook
          .ImageProperties.Resolution = 150
          .ImageProperties.RemoveEditData = True
          .ImageProperties.DoNotCompressImages = False
      End With
      '批量压缩所有图片：应用到文档全部+删除裁剪区域
      For Each shp In ws.Shapes
          If shp.Type = msoPicture Then
              shp.PictureFormat.Compress _
                  ApplyTo:=msoApplyToAllPictures, _
                  DeleteCroppedAreas:=msoTrue, _
                  Resolution:=msoPictureResolutionDefault
          End If
      Next
      Application.ScreenUpdating = True
      MsgBox "图片压缩完成！分辨率已设为150ppi，裁剪区域已删除", vbInformation
  End If
  
  '8.调整列宽
  ws.Columns(targetCol).AutoFit
  ws.Columns(targetCol + 1).ColumnWidth = 20
  MsgBox "共处理" & picFiles.Count & "张图片，操作完成！", vbInformation
  
  '释放对象
  Set fso = Nothing: Set folder = Nothing: Set picFiles = Nothing: Set ws = Nothing

End Sub