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

joforn · 发表于 2020-11-30 22:21

本帖最后由 joforn 于 2020-12-2 14:02 编辑

先上测试代码：

Sub TestSaveRangeToPictrue()
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", ",")
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"""
Next
FileNames = Split("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"""
Next
FileNames = Split("PNG,ICO,TGA,SVG", ",")
For I = 0 To UBound(FileNames)
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"""
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"""
Next
Debug.Print "=============　　测试结束　　==================="
End Sub
Sub TestSaveImageMso()
Dim PathName As String
Dim FileNames() As String
Dim FileName As String
Dim I As Long
On Error Resume Next
PathName = ThisWorkbook.Path & Application.PathSeparator
PathName = "T:\测试目录"
FileNames = Split("About,AccessRecycleBin,BlogHomePage,ClearGrid,Folder", ",")
For I = 0 To UBound(FileNames)
FileName = PathName & FileNames(I)
With CommandBars.GetImageMso(FileNames(I), 32, 32)
Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".PNG", &HFFFFFF), "成功", "失败") & "]：保存""" & FileNames(I) & """图标到文件""" & FileName & ".PNG""文件"
Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".ICO", &HFFFFFF, , 32), "成功", "失败") & "]：保存""" & FileNames(I) & """图标到文件""" & FileName & ".ICO""文件"
End With
Next
End Sub

复制代码

测试效果(本模块已完美通过XP+Office2007、Win7+Office2010(64位)、Win7+Office2007(32位)、Win10+Office2019(64位)测试)：

测试视频

本模块支持生成的文件格式：
1、BMP图片格式：32位位图文件，不支持透明；
2、PNG图片格式：生成32位带透明通道无损压缩图片；
3、ICO图片格式：生成Windows XP透明图标（注：VBA窗体中可能不能直接使用，不被VBA支持），要注意的是，如果没有为图标对应指定尺寸，那么生成的图标和Range区域大小相同，也就是说生成的图标并不是常见32×32或256×256之类的正方型图标；
4、TGA图片格式：生成32位带透明通道lwz无损压缩的TGA图片，由于TGA图片可被OpenGL直接调用做为3D贴图，故而常见于十多年前的老游戏素材中，但是要注意的是如果使用PS打开TGA文件的话，PS会忽略掉透明通道（包括PS自己生成的透明TGA图），但其它软件正常；
5、JPG/JPEG图片格式：最常见的有损压缩图片格式，不支持透明；
6、TIFF图片格式：不支持透明
7、GIF图片格式：不支持背景透明的GIF图片格式（注意：GIF格式本身是支持透明的，但本人偷懒，没去由自己生成二进制的GIF文件，所以本模块保存的GIF文件不支持背景透明）；
8、SVG图片格式: 矢量图，可以使用主流网页浏览器直接打开查看些类图片。
9、WMF图片格式：矢量图
10、EMF图片格式：矢量图
11、PDF文件格式：呃……
12、XPS文件格式：建议使用XPS Viewer查看(Win10自带，但需手动在组件中添加)
13、ZIP文件格式：这货只是为了帮助我们把上面生成的文件打包成一个文件。直接调用Shell32生成，无需第三方库支持，但是要注意的是如果使用的Ghost版XP系统的话，有些Ghost系统会把zipfldr.dll文件精减删除了，需要自己再去重新下载一个注册重启后才能成功生成Zip文件。

源码在这里：

游客，如果您要查看本帖隐藏内容请回复

如果只需要用到里面的功能的话，只需要把basSaveRangeToPictrue这个模块直接导出到其它的文件中，然后按上面的测试代码调用SaveRangeToPictrue就行了，里面还有SaveClipboardToPictrue、SaveBitmapToFile可以自己参照原代码中的格式和说明结合自己的情况调用，比如如果想将Excel中的Ribbon图标导出到ICO或是PNG，只要自己参照SaveBitmapToFile使用方法就可以直接导出到磁盘文件（上面的测试代码里也有演示）。

最后使用说明：
我TM忘了自己想说什么，算了，不打字了，吃饭去…………

不知道为什么 · 发表于 2020-12-1 06:13

本帖最后由 joforn 于 2020-12-2 09:54 编辑

来个沙发。。。。。

下面文字来自Joforn:
本来是要自己沙发然后用来补充一些说明的，但被这位兄弟抢了沙发，我只能利用自己的一点点特权直接占用了，希望层主不要介意
如果有函数运行失败的（其实我对完美成功运行不太感兴趣），希望能提示一下失败的问题是什么现象，比如：是完全一张图都没有输出还是某部分图形无输出？或是失败时直接整个Office消失不见了？如果能有动图或是能约个时间让我远程调试的话更好了。我把代码发出来，就是想让大家都运行运行，帮我测试出代码中的隐藏Bug。

另外补充一点说明：每种图片格式都会有高宽限制，比如：
WMF、EMF如果长度过长，会被截断——Excel自己截断的，还会有提示框，所以如果生成的图片太大的话不建议使用这类格式；
另外是TGA最大尺寸是65535×65535，这是由TGA文件格式的文件头决定的，我在处理里时发现有大于这个尺寸的图片会直接返回错误；
还有就是ICO本身最大的尺寸应该是256×256，但是我直接忽略了这个设置，所以生成的ICO并不是标准的ICO文件，但不会影响系统或是软件加载，只是老版本的软件可能加载不了。

aecn · 发表于 2020-12-1 10:35

太强大了，关注后续代码发布

企鹅先森 · 发表于 2020-12-1 10:37

期待大神作品

yylucke · 发表于 2020-12-1 10:44

期待，收藏了。
这样可以应用到：窗体订制表单背景，结合控件，使窗体展示为不同公司的表单。

opel-wong · 发表于 2020-12-1 11:20

做板凳先，
留个记号，

water882 · 发表于 2020-12-1 11:42

来占个位置，先坐板凳

VBAAider · 发表于 2020-12-1 19:23

谢谢，终于等到源码了。

gwjkkkkk · 发表于 2020-12-1 19:43

好东西，学习了，非常感谢

larer · 发表于 2020-12-1 20:20

就喜欢这种把针对某一个知识点的系统性的代码,感谢分享!

		自动登录	找回密码
密码			免费注册

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

评分