Excel保存单元格区域为图片(支持13种文件格式、背景透明、半透明、矢量图)

hb_mcc

感谢大师分享

wlwyhome

感谢分享学习一下

xftjywx

区域为图片(支持1

126085456

谢谢大佬，收藏学习

selen

' 将指定范围保存为多种格式的图片，并输出结果到控制台
Sub SaveRangeToPictures()
    Dim PathName As String ' 文件夹路径
    Dim FileNames() As String ' 要保存的文件类型数组
    Dim FileName As String ' 文件名
    Dim i As Long ' 循环计数器
   
    ' 设置文件夹路径
    PathName = "T:\测试目录" ' 修改为您要保存图像的文件夹路径
    PathName = ThisWorkbook.Path & Application.PathSeparator
   
    ' 输出开始测试信息到控制台
    Debug.Print "=============开始测试文件输出==================="
   
    ' 保存矢量图像、无透明图像和有背景透明度的图像
    FileNames = Split("WMF,EMF,PDF,XPS,BMP,PNG,ICO,JPG,TIF,TGA,SVG,GIF", ",")
    For i = 0 To UBound(FileNames)
        ' 保存不透明图像
        FileName = PathName & "SaveRangeTo" & FileNames(i) & "(无透明)." & FileNames(i)
        Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "成功", "失败") & "]：保存" & FileNames(i) & "文件""" & FileName & """"
        
        ' 添加不透明图像到压缩包中
        FileName = PathName & "Pictures.ZIP>无透明\SaveRangeTo" & FileNames(i) & "." & FileNames(i)
        Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "成功", "失败") & "]：添加" & FileNames(i) & "图片到""Pictures.ZIP"""
        
        ' 保存背景全透明图像
        FileName = PathName & "SaveRangeTo" & FileNames(i) & "(背景全透)." & FileNames(i)
        Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1), "成功", "失败") & "]：保存" & FileNames(i) & "文件""" & FileName & """"
        
        ' 添加背景全透明图像到压缩包中
        FileName = PathName & "Pictures.ZIP>透明\背景全透\SaveRangeTo" & FileNames(i) & "." & FileNames(i)
        Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1), "成功", "失败") & "]：添加" & FileNames(i) & "背景全透明图片到""Pictures.ZIP"""
        
        ' 保存背景半透明和整体半透明图像
        If InStr("PNG,ICO,TGA,SVG", FileNames(i)) > 0 Then
            ' 保存背景半透明图像
            FileName = PathName & "SaveRangeTo" & FileNames(i) & "(背景半透)." & FileNames(i)
            Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1, 128), "成功", "失败") & "]：保存" & FileNames(i) & "文件""" & FileName & """"
            
            ' 添加背景半透明图像到压缩包中
            FileName = PathName & "Pictures.ZIP>透明\背景半透\SaveRangeTo" & FileNames(i) & "." & FileNames(i)
            Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1, 128), "成功", "失败") & "]：添加" & FileNames(i) & "背景半透明图片到""Pictures.ZIP"""
            
            ' 保存整体半透明图像
            FileName = PathName & "SaveRangeTo" & FileNames(i) & "(整体半透)." & FileNames(i)
            Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -2, 128), "成功", "失败") & "]：保存" & FileNames(i) & "文件""" & FileName & """"

        ' 添加整体半透明图像到压缩包中
        FileName = PathName & "Pictures.ZIP>透明\整体半透\SaveRangeTo" & FileNames(i) & "." & FileNames(i)
        Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -2, 128), "成功", "失败") & "]：添加" & FileNames(i) & "整体半透明图片到""Pictures.ZIP"""
    End If
Next

' 输出结束测试信息到控制台
Debug.Print "=============　　测试结束　　==================="
End Sub

' 将指定的 Office 图标保存为 PNG 和 ICO 文件，并输出结果到控制台
Sub SaveImageMsoToFiles()
Dim PathName As String ' 文件夹路径
Dim IconNames() As String ' 要保存的图标名称数组
Dim FileName As String ' 文件名
Dim i As Long ' 循环计数器

On Error Resume Next

' 设置文件夹路径
PathName = ThisWorkbook.Path & Application.PathSeparator
PathName = "T:\测试目录" ' 修改为您要保存图标的文件夹路径

' 保存不同 Office 图标
IconNames = Split("About,AccessRecycleBin,BlogHomePage,ClearGrid,Folder", ",")
For i = 0 To UBound(IconNames)
    ' 设置文件名和路径
    FileName = PathName & IconNames(i)
   
    ' 获取特定 Office 图标并将其保存为 PNG 格式
    With CommandBars.GetImageMso(IconNames(i), 32, 32)
        Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".PNG", &HFFFFFF), "成功", "失败") & "]：保存""" & IconNames(i) & """图标到文件""" & FileName & ".PNG""文件"
        
        ' 将同一图标保存为 ICO 格式
        Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".ICO", &HFFFFFF, , 32), "成功", "失败") & "]：保存""" & IconNames(i) & """图标到文件""" & FileName & ".ICO""文件"
    End With
Next
End Sub

weiqigreen

谢谢大神，下载来学习一下。

lushang2018

感谢大神的作品，期待更完美的作品问世！

kitcause

太强大了，关注后续

invader09

感谢大佬分享！！

vistababy

我也来试试看。。