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

zldccmx

joforn 发表于 2021-9-1 15:01
最近有点忙，主要是客户拖款拖得厉害，今年都没什么时间玩了。网上应该这几个方面的代码都有现成的，自己 ...

这是我目前使用的方法，通过PowerShell 借助注册表，能够顺利将内存中的图片转换成Base64编码。

这有很大的局限性，毕竟PowerShell 不多见，至少XP系统没有。

请大神赐教。

smiletwo

                       牛牪犇

xiaomils

好强大，谢谢！

joforn

zldccmx 发表于 2021-9-1 17:00
这是我目前使用的方法，通过PowerShell 借助注册表，能够顺利将内存中的图片转换成Base64编码。

...

将一楼的附件中的basSaveRangeToPictrue导入到你自己的文件中，然后再把下面的代码粘贴的至basSaveRangeToPictrue文件尾：

1. 
   
2. Public Property Get BASE64PictrueFromClipboard(Optional ByVal ByVal strFileExt As String=".bmp", _
   
3.         Optional ByVal AlphaColorOrJPEGQuality As Variant, _
   
4.         Optional ByVal AlphaDepthOrColorDepth As Long, _
   
5.         Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION, _
   
6.         Optional ByVal NewWidth As Long, _
   
7.         Optional ByVal NewHeight As Long, _
   
8.         Optional ByVal PictureSizeMode As PictureSizeMode = Zoom) As String
   
9.       
   
10.   #If VBA7 Then
    
11.     Dim hBitmap   As LongPtr
    
12.     Dim ptrVar    As LongPtr
    
13.   #Else
    
14.     Dim hBitmap   As Long
    
15.     Dim ptrVar    As Long
    
16.   #End If
    
17. 
    
18.   Dim MetaFile    As METAFILEPICT
    
19.   
    
20.   Dim lngRet        As Long
    
21.   Dim bytFile() As Byte, hFile  As Long
    
22.   Dim FileName    As String
    
23.   Dim FileName2     As String
    
24.   
    
25.   On Error Resume Next
    
26.   
    
27.   lngRet = InStr(strFileExt, vbNullChar)
    
28.   If lngRet > 0 Then strFileExt = Left$(strFileExt, lngRet - 1)
    
29.   strFileExt = LCase$(Trim$(strFileExt))
    
30.   If Len(strFileExt) < 1 Then
    
31.     strFileExt = ".bmp"
    
32.   Else
    
33.     FileName = strFileExt
    
34.     strFileExt = GetFileExtension(FileName)
    
35.     If Len(strFileExt) < 1 Then
    
36.       strFileExt = GetFileExtension("." & FileName)
    
37.       If Len(strFileExt) < 1 Then strFileExt = ".bmp"
    
38.     End If
    
39.   End If
    
40.   
    
41.   FileName = String(512, vbNullChar): FileName2 = FileName
    
42.   If GetTempPath(512, StrPtr(FileName)) Then
    
43.     If GetTempFileName(StrPtr(FileName), StrPtr("Ron"), 0, StrPtr(FileName2)) Then
    
44.       KillFile FileName2
    
45.       If PathRenameExtensionW(StrPtr(FileName2), StrPtr(strFileExt)) Then
    
46.         lngRet = 0
    
47.         Do While PathFileExistsW(StrPtr(FileName2))
    
48.           lngRet = lngRet + 1
    
49.           If lngRet > 100 Then Exit Property
    
50.           If GetTempFileName(StrPtr(FileName), StrPtr("Ron"), 0, StrPtr(FileName2)) Then
    
51.             KillFile FileName2
    
52.             If PathRenameExtensionW(StrPtr(FileName2), StrPtr(strFileExt)) = 0 Then Exit Property
    
53.           End If
    
54.         Loop
    
55.       Else
    
56.         Exit Property
    
57.       End If
    
58.     End If
    
59.   End If
    
60.   
    
61.   lngRet = InStr(FileName2, vbNullChar)
    
62.   If lngRet > 0 Then
    
63.     FileName = Left$(FileName2, lngRet - 1)
    
64.   Else
    
65.     FileName = FileName2
    
66.   End If
    
67.   
    
68.   Select Case strFileExt
    
69.     Case ".emf"
    
70.       'EMF格式：背景透明，矢量图。
    
71.       If Not (KillFile(FileName)) Then Exit Property
    
72.       If IsClipboardFormatAvailable(CF_EnhancedMetafile) Then
    
73.         If OpenClipboard(0) Then
    
74.           hBitmap = GetClipboardData(CF_EnhancedMetafile)
    
75.           lngRet = GetEnhMetaFileBits(hBitmap, 0, 0)
    
76.           If (lngRet > 0) Then
    
77.             ReDim bytFile(0 To lngRet - 1)
    
78.             GetEnhMetaFileBits hBitmap, lngRet, varPtr(bytFile(0))
    
79.             hFile = FreeFile
    
80.             Open FileName For Binary As hFile
    
81.             Put hFile, , bytFile
    
82.             Close hFile
    
83.             If PathFileExistsW(StrPtr(FileName)) Then
    
84.               BASE64PictrueFromClipboard = GetFileBase64(FileName)
    
85.               KillFile FileName
    
86.             End If
    
87.           End If
    
88.           CloseClipboard
    
89.         End If
    
90.       End If
    
91.     Case ".wmf"
    
92.       'WMF格式：背景透明，矢量图
    
93.       If Not (KillFile(FileName)) Then Exit Property
    
94.       If IsClipboardFormatAvailable(CF_METAFILEPICT) Then
    
95.         If OpenClipboard(0) Then
    
96.           hBitmap = GetClipboardData(CF_METAFILEPICT)
    
97.           ptrVar = GlobalLock(hBitmap)
    
98.           CopyMemory varPtr(MetaFile), ptrVar, LenB(MetaFile)
    
99.           lngRet = GetMetaFileBitsEx(MetaFile.hMF, 0, 0)
    
100.           If (lngRet > 0) Then
     
101.             ReDim bytFile(0 To lngRet - 1)
     
102.             GetMetaFileBitsEx MetaFile.hMF, lngRet, varPtr(bytFile(0))
     
103.             hFile = FreeFile
     
104.             Open FileName For Binary As hFile
     
105.             Put hFile, , bytFile
     
106.             Close hFile
     
107.             If PathFileExistsW(StrPtr(FileName)) Then
     
108.               BASE64PictrueFromClipboard = GetFileBase64(FileName)
     
109.               KillFile FileName
     
110.             End If
     
111.           End If
     
112.           GlobalUnlock hBitmap
     
113.           CloseClipboard
     
114.         End If
     
115.       End If
     
116.     Case Else   '由位图转换
     
117.       If OpenClipboard(0) Then
     
118.         hBitmap = GetClipboardData(CF_Bitmap)
     
119.         CloseClipboard
     
120.         If SaveHBitmapToFile(hBitmap, FileName, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, _
     
121.                               ICO_SizeOrTIFF_COMPRESSION, NewWidth, NewHeight, PictureSizeMode) Then
     
122.           BASE64PictrueFromClipboard = GetFileBase64(FileName)
     
123.           KillFile FileName
     
124.         End If
     
125.       End If
     
126.   End Select
     
127. End Property
     
128. 
     

复制代码

然后，在你的代码中使用
Debug.Print BASE64PictrueFromClipboard
Debug.Print BASE64PictrueFromClipboard(".jpg")

Debug.Print BASE64PictrueFromClipboard("png")

或
Text=BASE64PictrueFromClipboard("gif")

joforn

不好意思，由于电脑中存档的文件与一楼附件中的代码不相同，所以上一个函数不能运行，用下面的代码替换就OK了
下载一楼的附件，并将下面的函数粘贴到basSaveRangeToPictrue模块尾端

1. 
   
2. Public Property Get BASE64PictrueFromClipboard(Optional ByVal strFileExt As String = ".bmp", _
   
3.        Optional ByVal AlphaColorOrJPEGQuality As Variant, _
   
4.        Optional ByVal AlphaDepthOrColorDepth As Long, _
   
5.        Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION) As String
   
6.       
   
7.   #If VBA7 Then
   
8.     Dim hBitmap   As LongPtr
   
9.     Dim ptrVar    As LongPtr
   
10.   #Else
    
11.     Dim hBitmap   As Long
    
12.     Dim ptrVar    As Long
    
13.   #End If
    
14. 
    
15.   Dim MetaFile    As METAFILEPICT
    
16.   
    
17.   Dim lngRet        As Long
    
18.   Dim bytFile() As Byte, hFile  As Long
    
19.   Dim FileName    As String
    
20.   Dim FileName2     As String
    
21.   
    
22.   On Error Resume Next
    
23.   
    
24.   lngRet = InStr(strFileExt, vbNullChar)
    
25.   If lngRet > 0 Then strFileExt = Left$(strFileExt, lngRet - 1)
    
26.   strFileExt = LCase$(Trim$(strFileExt))
    
27.   If Len(strFileExt) < 1 Then
    
28.     strFileExt = ".bmp"
    
29.   Else
    
30.     FileName = strFileExt
    
31.     strFileExt = GetFileExtension(FileName)
    
32.     If Len(strFileExt) < 1 Then
    
33.       strFileExt = GetFileExtension("." & FileName)
    
34.       If Len(strFileExt) < 1 Then strFileExt = ".bmp"
    
35.     End If
    
36.   End If
    
37.   
    
38.   FileName = String(512, vbNullChar): FileName2 = FileName
    
39.   If GetTempPath(512, StrPtr(FileName)) Then
    
40.     If GetTempFileName(StrPtr(FileName), StrPtr("Ron"), 0, StrPtr(FileName2)) Then
    
41.       KillFile FileName2
    
42.       If PathRenameExtensionW(StrPtr(FileName2), StrPtr(strFileExt)) Then
    
43.         lngRet = 0
    
44.         Do While PathFileExistsW(StrPtr(FileName2))
    
45.           lngRet = lngRet + 1
    
46.           If lngRet > 100 Then Exit Property
    
47.           If GetTempFileName(StrPtr(FileName), StrPtr("Ron"), 0, StrPtr(FileName2)) Then
    
48.             KillFile FileName2
    
49.             If PathRenameExtensionW(StrPtr(FileName2), StrPtr(strFileExt)) = 0 Then Exit Property
    
50.           End If
    
51.         Loop
    
52.       Else
    
53.         Exit Property
    
54.       End If
    
55.     End If
    
56.   End If
    
57.   
    
58.   lngRet = InStr(FileName2, vbNullChar)
    
59.   If lngRet > 0 Then
    
60.     FileName = Left$(FileName2, lngRet - 1)
    
61.   Else
    
62.     FileName = FileName2
    
63.   End If
    
64.   
    
65.   Select Case strFileExt
    
66.     Case ".emf"
    
67.       'EMF格式：背景透明，矢量图。
    
68.       If Not (KillFile(FileName)) Then Exit Property
    
69.       If IsClipboardFormatAvailable(CF_EnhancedMetafile) Then
    
70.         If OpenClipboard(0) Then
    
71.           hBitmap = GetClipboardData(CF_EnhancedMetafile)
    
72.           lngRet = GetEnhMetaFileBits(hBitmap, 0, 0)
    
73.           If (lngRet > 0) Then
    
74.             ReDim bytFile(0 To lngRet - 1)
    
75.             GetEnhMetaFileBits hBitmap, lngRet, VarPtr(bytFile(0))
    
76.             hFile = FreeFile
    
77.             Open FileName For Binary As hFile
    
78.             Put hFile, , bytFile
    
79.             Close hFile
    
80.             If PathFileExistsW(StrPtr(FileName)) Then
    
81.               BASE64PictrueFromClipboard = GetFileBase64(FileName)
    
82.               KillFile FileName
    
83.             End If
    
84.           End If
    
85.           CloseClipboard
    
86.         End If
    
87.       End If
    
88.     Case ".wmf"
    
89.       'WMF格式：背景透明，矢量图
    
90.       If Not (KillFile(FileName)) Then Exit Property
    
91.       If IsClipboardFormatAvailable(CF_METAFILEPICT) Then
    
92.         If OpenClipboard(0) Then
    
93.           hBitmap = GetClipboardData(CF_METAFILEPICT)
    
94.           ptrVar = GlobalLock(hBitmap)
    
95.           CopyMemory VarPtr(MetaFile), ptrVar, LenB(MetaFile)
    
96.           lngRet = GetMetaFileBitsEx(MetaFile.hMF, 0, 0)
    
97.           If (lngRet > 0) Then
    
98.             ReDim bytFile(0 To lngRet - 1)
    
99.             GetMetaFileBitsEx MetaFile.hMF, lngRet, VarPtr(bytFile(0))
    
100.             hFile = FreeFile
     
101.             Open FileName For Binary As hFile
     
102.             Put hFile, , bytFile
     
103.             Close hFile
     
104.             If PathFileExistsW(StrPtr(FileName)) Then
     
105.               BASE64PictrueFromClipboard = GetFileBase64(FileName)
     
106.               KillFile FileName
     
107.             End If
     
108.           End If
     
109.           GlobalUnlock hBitmap
     
110.           CloseClipboard
     
111.         End If
     
112.       End If
     
113.     Case Else   '由位图转换
     
114.       If OpenClipboard(0) Then
     
115.         hBitmap = GetClipboardData(CF_Bitmap)
     
116.         CloseClipboard
     
117.         If SaveBitmapToFile(hBitmap, FileName & vbNullChar & FileName2, AlphaColorOrJPEGQuality, _
     
118.                             AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION) Then
     
119.           BASE64PictrueFromClipboard = GetFileBase64(FileName)
     
120.           KillFile FileName
     
121.         End If
     
122.       End If
     
123.   End Select
     
124. End Property
     
125. 
     

复制代码

调用：
Sub TestOutBASE64()
  Range("L1:R21").Copy
  Debug.Print BASE64PictrueFromClipboard
  Debug.Print BASE64PictrueFromClipboard(".png")  

End Sub

tangfeihust

学习了，向大神致敬

zldccmx

joforn 发表于 2021-9-2 00:00
不好意思，由于电脑中存档的文件与一楼附件中的代码不相同，所以上一个函数不能运行，用下面的代码替换就OK ...

衷心感谢大神！

dengcaimao

好好学习，点赞

zhao__feng

期待大神作品

zhenzijian

我来测试一下！！！