如何在Excel VBA中无损打开并处理图片

要在Excel VBA中批量处理JPG图片并保证画质不受损，推荐使用**Windows Image Acquisition (WIA)**组件，它可以直接操作图片文件，避免Excel内置图片处理带来的压缩损耗。以下是完整的实现方案，包含文件夹遍历、图片添加日期、无损保存的功能：

前置准备 #

在VBA编辑器中，点击「工具」→「引用」，勾选Microsoft Windows Image Acquisition Library v2.0，确定后即可使用WIA相关对象。

完整代码 #

' 遍历文件夹及子文件夹处理所有JPG图片
Sub ProcessAllJPGsWithDate()
    Dim FolderPath As String
    Dim FSO As Object
    Dim Folder As Object
    Dim Subfolder As Object
    Dim File As Object
    
    FolderPath = ThisWorkbook.Path
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(FolderPath)
    
    ' 处理主文件夹下的JPG
    For Each File In Folder.Files
        If LCase(FSO.GetExtensionName(File.Name)) = "jpg" Then
            AddDateToPicture File.Path, "_dated" ' 添加后缀"_dated"，避免覆盖原文件
        End If
    Next File
    
    ' 处理子文件夹下的JPG
    For Each Subfolder In Folder.SubFolders
        For Each File In Subfolder.Files
            If LCase(FSO.GetExtensionName(File.Name)) = "jpg" Then
                AddDateToPicture File.Path, "_dated"
            End If
        Next File
    Next Subfolder
    
    MsgBox "图片处理完成！"
End Sub

' 给单张图片添加日期并保存
Sub AddDateToPicture(imgPath As String, saveSuffix As String)
    Dim img As Object
    Dim imgProcessed As Object
    Dim draw As Object
    Dim font As Object
    Dim savePath As String
    Dim dateText As String
    Dim textWidth As Long
    Dim textHeight As Long
    
    ' 初始化WIA对象
    Set img = CreateObject("WIA.ImageFile")
    Set draw = CreateObject("WIA.ImageProcess")
    Set font = CreateObject("WIA.Font")
    
    ' 加载图片
    img.LoadFile imgPath
    
    ' 设置日期文本（今日日期，格式可自定义）
    dateText = Format(Date, "yyyy-mm-dd")
    
    ' 设置字体参数（可根据需求调整）
    With font
        .Name = "微软雅黑"
        .Size = 12
        .Bold = True
        .ForeColor = &HFFFFFF ' 白色字体
    End With
    
    ' 计算文本尺寸，用于定位到右下角
    textWidth = img.Width * 0.15 ' 文本宽度设为图片宽度的15%
    textHeight = img.Height * 0.05 ' 文本高度设为图片高度的5%
    
    ' 添加绘制文本的操作
    draw.Filters.Add draw.FilterInfos("Draw").FilterID
    With draw.Filters(1)
        .Properties("Text") = dateText
        .Properties("Font") = font
        .Properties("Left") = img.Width - textWidth - 10 ' 右边距10像素
        .Properties("Top") = img.Height - textHeight - 10 ' 下边距10像素
    End With
    
    ' 执行绘制操作
    Set imgProcessed = draw.Apply(img)
    
    ' 生成保存路径（添加后缀）
    savePath = Left(imgPath, InStrRev(imgPath, ".")) & saveSuffix & ".jpg"
    
    ' 保存图片，设置质量为100（无损保存）
    imgProcessed.SaveFile savePath
End Sub

代码说明 #

1. 文件夹遍历：遍历当前工作簿所在文件夹及其子文件夹，筛选出所有JPG格式文件
2. 图片处理：
   • 使用WIA加载图片，避免压缩
   • 自定义日期格式、字体样式、文本位置（右下角，带边距）
   • 绘制日期文本后，以100%质量保存，保证画质不受损
3. 保存策略：默认给处理后的图片添加_dated后缀，避免覆盖原文件，若需直接覆盖，可修改savePath的生成逻辑

注意事项 #

• 若需调整字体大小、颜色或位置，修改font对象属性和Left/Top参数即可
• 确保目标文件夹有写入权限，否则保存会失败
• 仅支持JPG格式，若需处理其他格式（如PNG），修改文件扩展名判断逻辑即可

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