返回列表 上一主題 發帖

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

[原創] 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. Sub TestSaveImageMso()
  45.   Dim PathName As String
  46.   Dim FileNames() As String
  47.   Dim FileName As String
  48.   Dim I As Long
  49.   
  50.   On Error Resume Next
  51.   
  52.   PathName = ThisWorkbook.Path & Application.PathSeparator
  53.   FileNames = Split("About,AccessRecycleBin,BlogHomePage,ClearGrid,Folder", ",")
  54.   For I = 0 To UBound(FileNames)
  55.     FileName = PathName & FileNames(I)
  56.     With CommandBars.GetImageMso(FileNames(I), 32, 32)
  57.       Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".PNG", &HFFFFFF), "成功", "失敗") & "]:保存""" & FileNames(I) & """圖標到文件""" & FileName & ".PNG""文件"
  58.       Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".ICO", &HFFFFFF, , 32), "成功", "失敗") & "]:保存""" & FileNames(I) & " ""圖標到文件""" & FileName & ".ICO""文件"
  59.     End With
  60.   Next
  61. End Sub
複製代碼



測試效果(本模組已完美通過XP+Office2007、Win7+Office2010(64位)、Win7+Office2007(32位)、Win10+Office2019(64位)測試):

SaveRangeToPictrue.gif
2020-12-1 19:50


本模塊支持生成的文件格式:
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中的方法即可導出到磁碟中。
世界那麼大,可我想去哪?

一樓的附件忘記去掉代碼中的簡體中文了,這個是新的附件: SaveRangeToPictrue_EN.zip (157.37 KB)
世界那麼大,可我想去哪?

TOP

        靜思自在 : 【蒙蔽的自由】人常在什麼都可以自由自在的時候,卻被這種隨心所欲的自由蒙蔽,虛擲時光而毫無覺知。
返回列表 上一主題