请教大神：VBA怎样导出图片？谢！

白云无尽9987

psxk3535 发表于 2021-10-19 23:20
看看 https://club.excelhome.net/thread-1565669-1-1.html  joforn老师的代码可以保存成透明图片，看了 ...

可以的，是大神测试过的，但是貌似不是导出原图，而是截图保存为透明色的，

psxk3535

白云无尽9987 发表于 2021-10-21 13:57
可以的，是大神测试过的，但是貌似不是导出原图，而是截图保存为透明色的，

偶然的机会看到了一句代码。.ShapeRange.Fill.Visible = msoFalse，好用

aecn

把工作簿另存为HTML格式就可以了

白云无尽9987

aecn 发表于 2021-10-21 14:26
把工作簿另存为HTML格式就可以了

这种方法，遗憾的是名称不可控啊！

白云无尽9987

psxk3535 发表于 2021-10-21 14:18
你看看我这个可以吗，偶然的机会看到了一句代码。能力所限，改了好多遍，你试试，我这里暂时没有问题，可 ...

太好了！感激不尽！

疯狂的肥肉

看下是否符合要求

psxk3535

疯狂的肥肉 发表于 2021-10-21 20:20
看下是否符合要求

不行，我试了一下，导出的还是不透明的，你把导出的图片重新插入试试就知道了。加上这个代码，.ShapeRange.Fill.Visible = msoFalse  修改一下，就是透明的，不能按常理出牌，不知道到底是为什么。

小fisher

1. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
   
2. Private Declare Function CloseClipboard Lib "user32" () As Long
   
3. Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
   
4. Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
   
5. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
   
6. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
   
7. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
   
8. Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
   
9. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
   
10. 
    
11. Sub saveRange2PNG(SourceRange As Range, sPNGFile As String)
    
12.     Dim lFormat As Long
    
13.     Dim nSize As Long
    
14.     Dim hClip As Long
    
15.     Dim pData As Long
    
16.     Dim bytBuffer() As Byte
    
17.     Dim iFreeFile As Integer
    
18.    
    
19.     '复制单元格区域为图片
    
20.     SourceRange.CopyPicture xlScreen, xlPicture
    
21.     '粘贴到当前工作表中
    
22.     ActiveSheet.Paste
    
23.     '将单元格区域转变的图片再次剪切，剪贴板中就会出现一个格式为"PNG"的内容，读出其所含字节保存到硬盘中即为一个PNG文件
    
24.     Selection.Cut
    
25.    
    
26.     '以下是读取剪贴板中指定格式对应字节内容并保存到硬盘的常规代码，详见https://club.excelhome.net/thread-1057488-1-1.html
    
27.     If OpenClipboard(0) <> 0 Then
    
28.         lFormat = RegisterClipboardFormat("PNG")
    
29.         If IsClipboardFormatAvailable(lFormat) Then
    
30.             hClip = GetClipboardData(lFormat)
    
31.             pData = GlobalLock(hClip)
    
32.             nSize = GlobalSize(hClip)
    
33.             ReDim bytBuffer(nSize - 1)
    
34.             CopyMemory VarPtr(bytBuffer(0)), pData, nSize
    
35.             GlobalUnlock hClip
    
36.             
    
37.             '如果目标文件已存在，长度为m字节，要保存的png文件长度为n字节，并且m>n，如果直接保存将只替换前n个字节，后面m-n个字节仍然是旧文件内容
    
38.             '需要在检查到文件已存在时用kill语句，或者用下面三句代码先将目标文件变为一个0字节的空文件
    
39.             iFreeFile = FreeFile
    
40.             Open sPNGFile For Output As iFreeFile
    
41.             Close iFreeFile
    
42.             
    
43.             iFreeFile = FreeFile
    
44.             Open sPNGFile For Binary As iFreeFile
    
45.                 Put iFreeFile, , bytBuffer
    
46.             Close iFreeFile
    
47.         End If
    
48.         CloseClipboard
    
49.     End If
    
50. End Sub
    
51. 
    
52. Sub test()
    
53.     Dim sFile As String
    
54.     sFile = Application.GetSaveAsFilename("C:", "PNG图片(*.png),*.png", , "单元格区域另存为PNG", "保存图片")
    
55.     'saveRange2PNG函数内部并不检查目标文件是否已存在，在使用前应进行检查并提醒用户，以免误覆盖
    
56.     If Len(Dir(sFile, vbSystem + vbHidden)) > 0 Then
    
57.         If MsgBox("文件" & sFile & "已存在，是否覆盖？", vbYesNo) = vbNo Then Exit Sub
    
58.     End If
    
59.     saveRange2PNG Sheet1.Range("a1:E4"), sFile
    
60. End Sub
    

复制代码

白云无尽9987

疯狂的肥肉 发表于 2021-10-21 20:20
看下是否符合要求

这个倒是简单，但是很多要求都没有达到的..

dongdonggege

小fisher 发表于 2021-10-22 16:58

大师的作品，我也学习下。