返回列表下一主題上一主題發帖

[原創] Excel保存单元格区域为图片

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

帖子: 109
主題: 2
精華: 0
積分: 114
點名: 0
作業系統: Win7 Win10
軟體版本: Office 2019 WPS
閱讀權限: 20
性別: 男
來自: 深圳
註冊時間: 2013-2-2
最後登錄: 2024-11-6

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2020-12-1 19:58 | 只看該作者

[原創] Excel保存单元格区域为图片

圖片, 透明, ICO, 格式, 矢量

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

先上測試代碼：

Sub TestSaveRangeToPictrue()
Dim PathName As String
Dim FileNames() As String
Dim FileName As String
Dim I As Long
Debug.Print "=============開始測試文件輸出==================="
PathName = ThisWorkbook.Path & Application.PathSeparator
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
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生成，無需第三方DLL支持。

源碼在這裡：

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