標題: [原創] Excel保存单元格区域为图片 [打印本頁]

---

作者: Joforn    時間: 2020-12-1 19:58     標題: Excel保存单元格区域为图片

本帖最後由 Joforn 於 2020-12-1 20:03 編輯

先上測試代碼：

1. Sub TestSaveRangeToPictrue()
   
2.   Dim PathName As String
   
3.   Dim FileNames() As String
   
4.   Dim FileName As String
   
5.   Dim I As Long
   
6.   
   
7.   
   
8.   Debug.Print "=============開始測試文件輸出==================="
   
9.   PathName = ThisWorkbook.Path & Application.PathSeparator
   
10.   
    
11.   FileNames = Split("WMF,EMF,PDF,XPS", ",")
    
12.   For I = 0 To UBound(FileNames)
    
13.     FileName = PathName & "SaveRangeTo" & FileNames(I) & "(矢量)." & FileNames(I)
    
14.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "成功", "失敗") & "]：保存" & FileNames(I) & "文件""" & FileName & """"
    
15.     FileName = PathName & "Pictures.ZIP>矢量\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    
16.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "成功", "失敗") & "]：添加" & FileNames(I) & "文件到""Pictures. ZIP"""
    
17.   Next
    
18.   
    
19.   FileNames = Split("BMP,PNG,ICO,JPG,TIF,TGA,SVG,GIF", ",")
    
20.   For I = 0 To UBound(FileNames)
    
21.     FileName = PathName & "SaveRangeTo" & FileNames(I) & "(無透明)." & FileNames(I)
    
22.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "成功", "失敗") & "]：保存" & FileNames(I) & "文件""" & FileName & """"
    
23.     FileName = PathName & "Pictures.ZIP>無透明\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    
24.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "成功", "失敗") & "]：添加" & FileNames(I) & "圖片到""Pictures. ZIP"""
    
25.   Next
    
26.   
    
27.   FileNames = Split("PNG,ICO,TGA,SVG", ",")
    
28.   For I = 0 To UBound(FileNames)
    
29.     FileName = PathName & "SaveRangeTo" & FileNames(I) & "(背景全透)." & FileNames(I)
    
30.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1), "成功", "失敗") & "]：保存" & FileNames(I) & "文件"" " & FileName & """"
    
31.     FileName = PathName & "Pictures.ZIP>透明\背景全透\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    
32.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1), "成功", "失敗") & "]：添加" & FileNames(I) & "背景全透明圖片到""Pictures.ZIP"""
    
33.     FileName = PathName & "SaveRangeTo" & FileNames(I) & "(背景半透)." & FileNames(I)
    
34.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1, 128), "成功", "失敗") & "]：保存" & FileNames(I) & "文件""" & FileName & """"
    
35.     FileName = PathName & "Pictures.ZIP>透明\背景半透\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    
36.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1, 128), "成功", "失敗") & "]：添加" & FileNames(I) & "背景半透明圖片到""Pictures.ZIP"""
    
37.     FileName = PathName & "SaveRangeTo" & FileNames(I) & "(整體半透)." & FileNames(I)
    
38.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -2, 128), "成功", "失敗") & "]：保存" & FileNames(I) & "文件""" & FileName & """"
    
39.     FileName = PathName & "Pictures.ZIP>透明\整體半透\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    
40.     Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -2, 128), "成功", "失敗") & "]：添加" & FileNames(I) & "整體半透明圖片到""Pictures.ZIP"""
    
41.   Next
    
42.   Debug.Print "=============　　測試結束　　==================="
    
43. End Sub
    
44. 
    
45. 
    
46. Sub TestSaveImageMso()
    
47.   Dim PathName As String
    
48.   Dim FileNames() As String
    
49.   Dim FileName As String
    
50.   Dim I As Long
    
51.   
    
52.   On Error Resume Next
    
53.   
    
54.   PathName = ThisWorkbook.Path & Application.PathSeparator
    
55.   FileNames = Split("About,AccessRecycleBin,BlogHomePage,ClearGrid,Folder", ",")
    
56.   For I = 0 To UBound(FileNames)
    
57.     FileName = PathName & FileNames(I)
    
58.     With CommandBars.GetImageMso(FileNames(I), 32, 32)
    
59.       Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".PNG", &HFFFFFF), "成功", "失敗") & "]：保存""" & FileNames(I) & """圖標到文件""" & FileName & ".PNG""文件"
    
60.       Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".ICO", &HFFFFFF, , 32), "成功", "失敗") & "]：保存""" & FileNames(I) & " ""圖標到文件""" & FileName & ".ICO""文件"
    
61.     End With
    
62.   Next
    
63. End Sub

複製代碼

測試效果(本模組已完美通過XP+Office2007、Win7+Office2010(64位)、Win7+Office2007(32位)、Win10+Office2019(64位)測試)：
[attach]32740[/attach]

本模塊支持生成的文件格式：
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生成，無需第三方DLL支持。

源碼在這裡：[attach]32739[/attach]
如果只需要用到裡面的功能的話，可以僅僅導出basSaveRangeToPictrue模組到其它的VBA專案中，依照上面的測試代碼中的方式調用SaveRangeToPictrue函數就OK了，模組中還有SaveClipboardToPictrue、SaveBitmapToFile兩個函數，亦可參照原代碼中的格式和說明結合自己的實際需求調用。比如：如果想將Excel中的Ribbon圖標導出為ICO文檔或是PNG文檔，僅需依照TestSaveImageMso中的方法即可導出到磁碟中。

---

作者: Joforn    時間: 2020-12-2 13:44

一樓的附件忘記去掉代碼中的簡體中文了，這個是新的附件:[attach]32742[/attach]

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)