【源码】VBA(Access或Excel)如何将剪切板的图片数据保存为BMP或JPG文件

tmtony

在帮林岚做一个将Excel的任意单元格的内容复制转为图片，然后将图片再另存为BMP或JPG
开始是使用excel自带的方法，先复制单元格内容，然后按住shift 点击编辑 菜单，有一个 复制为图片 的菜单项。这样图片就转到剪切板了
再对剪切板进行编程
后来发现还有有点麻烦。
就改成直接做成一个通用函数，可对任何指定的区域操作，将指定的区域内容直接转换保存为指定的文件。

一、调用方法非常的简单，方法如下：  (www.Office-cn.net)

---

      
       SaveRangePic Sheet1.Range("E10:F11"), "C:\tmtony.bmp"

二、值得注意的几点

---

1.要定义好相应的API。可放在模块或本窗体中
2.如果你的Access同时引用了word和excel,因为word 和excel都有range对象，所以要显示将函数的range改为excel.range ,否则调用将失败
    或将excel的引用放在前面也可以

三、详细的API定义及通用函数的完整源码及注释

1. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
   
2. 
   
3. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
   
4. 
   
5. Private Declare Function CloseClipboard Lib "user32" () As Long
   
6. 
   
7. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
   
8. (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
   
9. IPic As IPicture) As Long
   
10. 
    
11. '\\ 定义一个 UDT 来保存IPicture OLE接口的 GUID
    
12. Private Type GUID
    
13. Data1 As Long
    
14. Data2 As Integer
    
15. Data3 As Integer
    
16. Data4(0 To 7) As Byte
    
17. End Type
    
18. 
    
19. '\\ 定义一个 UDT保存 bitmap信息
    
20. Private Type uPicDesc
    
21. Size As Long
    
22. Type As Long
    
23. hPic As Long
    
24. hPal As Long
    
25. End Type
    
26. 
    
27. Private Const CF_BITMAP = 2
    
28. Private Const PICTYPE_BITMAP = 1
    
29. 
    
30. 'Office中国通用函数 可将任意Excel区域 内容复制并另存为图片
    
31. Private Sub SaveRangePic(SourceRange As Range, FilePathName As String)
    
32. 
    
33. 
    
34. Dim IID_IDispatch As GUID
    
35. Dim uPicinfo As uPicDesc
    
36. Dim IPic As IPicture
    
37. Dim hPtr As Long
    
38. 
    
39. '\\ 复制Range到剪切板 ClipBoard  www.office-cn.net
    
40. SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
41. OpenClipboard 0
    
42. hPtr = GetClipboardData(CF_BITMAP)
    
43. CloseClipboard
    
44. 
    
45. '\\ 为picture图片创建一个 GUID 接口
    
46. With IID_IDispatch
    
47. .Data1 = &H7BF80980
    
48. .Data2 = &HBF32
    
49. .Data3 = &H101A
    
50. .Data4(0) = &H8B
    
51. .Data4(1) = &HBB
    
52. .Data4(2) = &H0
    
53. .Data4(3) = &HAA
    
54. .Data4(4) = &H0
    
55. .Data4(5) = &H30
    
56. .Data4(6) = &HC
    
57. .Data4(7) = &HAB
    
58. End With
    
59. 
    
60. '\\用相关数据填充 uPicInfo
    
61. With uPicinfo
    
62. .Size = Len(uPicinfo) '结构体长度
    
63. .Type = PICTYPE_BITMAP '图片类型
    
64. .hPic = hPtr '图片句柄
    
65. .hPal = 0 '\\ palette句柄 (如果 是 bitmap).
    
66. End With
    
67. 
    
68. '\\创建Range对应的 Picture对象
    
69. OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    
70. 
    
71. '\\另存 Picture 对象到文件
    
72. stdole.SavePicture IPic, FilePathName
    
73. 
    
74. End Sub

复制代码

四、以前网站和论坛与剪切板相关的贴子和链接（几乎涉及到剪切板的大部分操作的源码）

---

1.用代码插入图片到OLE对象的2种方法
   http://www.access-cn.com/info/info3396.html
2.Access从剪切版里复制和粘贴数据
   http://www.access-cn.com/info/info2045.html
3.最全的有关剪切板（ClipBoard）的各种操作和相关源代码集锦   
    http://www.office-cn.net/thread-119761-1-1.html
4.VBA保存剪贴板为Bmp(加PrtScrn截屏)
    http://www.access-cn.com/info/info3461.html
5.VBA保存剪贴板为JPG(加PrtScrn截屏)
   http://www.access-cn.com/info/info3460.html

五、网上搜索的相关资料（放在这里做个备忘，以免忘记），同时稍做了一下分类与整理，也给有同样问题的网友一个参考，希望对你们有用

---

1.将Excel整个截屏并另存为BMP文件 （测试是成功的）

1. Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
   
2. Enum JpMode
   
3.       theScreen = 0 '全屏截图
   
4.       theForm = 1 '当前焦点窗口截图
   
5. End Enum
   
6. 
   
7. 
   
8. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
   
9. Private Declare Function CloseClipboard Lib "user32" () As Long
   
10. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    
11. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    
12. Private Const CF_BITMAP = 2
    
13. Private Type PicBmp
    
14.     Size As Long
    
15.     Type As Long
    
16.     hBmp As Long
    
17.     hPal As Long
    
18.     Reserved As Long
    
19. End Type
    
20. 
    
21. Private Type Guid
    
22.     Data1 As Long
    
23.     Data2 As Integer
    
24.     Data3 As Integer
    
25.     Data4(0 To 7) As Byte
    
26. End Type
    
27. Function ApiGetClipBmp() As IPicture
    
28. On Error Resume Next
    
29.     Dim Pic As PicBmp, IID_IDispatch As Guid
    
30.     OpenClipboard 0 'OpenClipboard
    
31.     With IID_IDispatch
    
32.         .Data1 = &H20400
    
33.         .Data4(0) = &HC0
    
34.         .Data4(7) = &H46
    
35.     End With
    
36. 
    
37.     With Pic
    
38.         .Size = Len(Pic)
    
39.         .Type = 1
    
40.         .hBmp = GetClipboardData(CF_BITMAP)
    
41.     End With
    
42.    
    
43.     OleCreatePictureIndirect Pic, IID_IDispatch, 1, ApiGetClipBmp
    
44.     'stdole.SavePicture ApiGetClipBmp, "c:\clipboard.bmp"
    
45.     CloseClipboard
    
46. End Function
    
47. Function KeyJp(Optional ByVal TheMode As JpMode = theScreen) As IPictureDisp
    
48.    '版权所有，请保留作者信息.QQ：1085992075   '如需商业用途请联系作者
    
49.       Call keybd_event(vbKeySnapshot, TheMode, 0, 0) '
    
50.       DoEvents
    
51.       'Set KeyJp = Clipboard.GetData
    
52. End Function
    
53. '┗〓〓〓〓〓〓〓〓〓  KeyJp,end  〓〓〓〓〓〓〓〓〓┛
    
54. Sub dd()
    
55.   KeyJp (theScreen)
    
56.   SavePicture ApiGetClipBmp, "c:\2.bmp"
    
57. End Sub

复制代码

2.这个程序说起来也不复杂，涉及到两类API函数，一类是剪贴板函数，用于读取剪贴板中的位图句柄，另外一类是GDI+函数，用于位图到jpg文件的转换，具体代码如下：

1. Option Explicit
   
2. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
   
3. Private Declare Function CloseClipboard Lib "user32" () As Long
   
4. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
   
5. Private Const CF_BITMAP = 2
   
6. 
   
7. Private Type GUID
   
8. Data1 As Long
   
9. Data2 As Integer
   
10. Data3 As Integer
    
11. Data4(0 To 7) As Byte
    
12. End Type
    
13. 
    
14. Private Type GdiplusStartupInput
    
15. GdiplusVersion As Long
    
16. DebugEventCallback As Long
    
17. SuppressBackgroundThread As Long
    
18. SuppressExternalCodecs As Long
    
19. End Type
    
20. 
    
21. Private Type EncoderParameter
    
22. GUID As GUID
    
23. NumberOfValues As Long
    
24. type As Long
    
25. Value As Long
    
26. End Type
    
27. 
    
28. Private Type EncoderParameters
    
29. Count As Long
    
30. Parameter As EncoderParameter
    
31. End Type
    
32. 
    
33. Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
    
34. Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    
35. Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    
36. Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    
37. Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    
38. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
    
39. 
    
40. Sub test()
    
41.     Select Case CliptoJPG("c:\test.jpg")
    
42.         Case 0:
    
43.             MsgBox "剪贴板图片已保存"
    
44.         Case 1:
    
45.             MsgBox "剪贴板图片保存失败"
    
46.         Case 2:
    
47.             MsgBox "剪贴板中无图片"
    
48.         Case 3:
    
49.             MsgBox "剪贴板无法打开，可能被其他程序所占用"
    
50.     End Select
    
51. End Sub
    
52. 
    
53. 
    
54. Private Function CliptoJPG(ByVal destfilename As String, Optional ByVal quality As Byte = 80) As Integer
    
55. '*****该函数用于取出剪贴板中图片转换为jpg文件另存到指定路径****
    
56. '参数说明：
    
57. '     destfilename:要保存的jpg文件的完整路径，必要参数；
    
58. '     quality: jpg文件的质量，0-100之间的数值，数值越大，图片质量越高
    
59. '返回值：
    
60. '     0-保存成功；1-保存失败；2-剪贴板中无位图数据；3-无法打开剪贴板
    
61. 
    
62.     Dim tSI As GdiplusStartupInput
    
63.     Dim lRes As Long
    
64.     Dim lGDIP As Long
    
65.     Dim lBitmap As Long
    
66.     Dim hBmp As Long
    
67.    
    
68.     '尝试打开剪贴板
    
69.     If OpenClipboard(0) Then
    
70.         '尝试取出剪贴板中位图的句柄
    
71.         hBmp = GetClipboardData(CF_BITMAP)
    
72.         '如果hBmp为0，说明剪贴板中没有存放图片
    
73.         If hBmp = 0 Then
    
74.             CliptoJPG = 2
    
75.             CloseClipboard
    
76.             Exit Function
    
77.         End If
    
78.         CloseClipboard
    
79.     Else   '如果openclipboard返回0(False)，说明剪贴板被其他程序所占用
    
80.         CliptoJPG = 3
    
81.         Exit Function
    
82.     End If
    
83.    
    
84.     '初始化 GDI+
    
85.     tSI.GdiplusVersion = 1
    
86.     lRes = GdiplusStartup(lGDIP, tSI, 0)
    
87.      
    
88.     If lRes = 0 Then
    
89.         '从句柄创建 GDI+ 图像
    
90.         lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
    
91.          
    
92.         If lRes = 0 Then
    
93.             Dim tJpgEncoder As GUID
    
94.             Dim tParams As EncoderParameters
    
95.             
    
96.             '初始化解码器的GUID标识
    
97.             CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
    
98.             
    
99.             '设置解码器参数
    
100.             tParams.Count = 1
     
101.             With tParams.Parameter ' Quality
     
102.                 '得到Quality参数的GUID标识
     
103.                 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
     
104.                 .NumberOfValues = 1
     
105.                 .type = 4
     
106.                 .Value = VarPtr(quality)
     
107.             End With
     
108.             
     
109.             '保存图像
     
110.             lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
     
111.             If lRes = 0 Then
     
112.                 CliptoJPG = 0  '转换成功
     
113.             Else
     
114.                 CliptoJPG = 1  '转换失败
     
115.             End If
     
116.             
     
117.             '销毁GDI+图像
     
118.             GdipDisposeImage lBitmap
     
119.         End If
     
120.          
     
121.         '销毁 GDI+
     
122.         GdiplusShutdown lGDIP
     
123.     End If
     
124. End Function

复制代码

t小宝

好资料！

玉树TMD临风

这么麻烦的。

打开的记录集某个字段怎样取剪贴板的值？

比如rst（"地址"）=后面怎么写？

p51219

好好好呵呵呵呵呵