设为首页收藏本站Access中国
开启辅助访问

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步，快速开始

Office中国论坛/Access中国论坛 › Access中国门户旧版 ›Access› API › 查看内容

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

2015-4-17 23:45| 发布者: tmtony| 查看: 6140| 评论: 3|原作者: tmtony|来自: Office中国

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


  2. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

  4. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

  6. Private Declare Function CloseClipboard Lib "user32" () As Long

  8. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
  9. (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
  10. IPic As IPicture) As Long

  12. '\\ 定义一个 UDT 来保存IPicture OLE接口的 GUID
  13. Private Type GUID
  14. Data1 As Long
  15. Data2 As Integer
  16. Data3 As Integer
  17. Data4(0 To 7) As Byte
  18. End Type

  20. '\\ 定义一个 UDT保存 bitmap信息
  21. Private Type uPicDesc
  22. Size As Long
  23. Type As Long
  24. hPic As Long
  25. hPal As Long
  26. End Type

  28. Private Const CF_BITMAP = 2
  29. Private Const PICTYPE_BITMAP = 1

  31. Private Sub SaveRangePic(SourceRange As Range, FilePathName As String)


  34. Dim IID_IDispatch As GUID
  35. Dim uPicinfo As uPicDesc
  36. Dim IPic As IPicture
  37. Dim hPtr As Long

  39. '\\ 复制Range到剪切板 ClipBoard
  40. SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
  41. OpenClipboard 0
  42. hPtr = GetClipboardData(CF_BITMAP)
  43. CloseClipboard

  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

  60. '\\用相关数据填充 uPicInfo
  61. With uPicinfo
  62. .Size = Len(uPicinfo) '结构体长度
  63. .Type = PICTYPE_BITMAP '图片类型
  64. .hPic = hPtr '图片句柄
  65. .hPal = 0 '\\ palette句柄 (如果 是 bitmap).
  66. End With

  68. '\\创建Range对应的 Picture对象
  69. OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic

  71. '\\另存 Picture 对象到文件
  72. stdole.SavePicture IPic, FilePathName

  74. End Sub
复制代码


调用方法非常的简单，方法如下：  (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的引用放在前面也可以

以前网站和论坛与剪切板相关的贴子和链接（几乎涉及到剪切板的大部分操作的源码）
1.用代码插入图片到OLE对象的2种方法
   http://www.access-cn.com/info/info3396.html
2.Access从剪切版里复制和粘贴数据
   http://www.access-cn.com/info/info2045.html
3.如何把字符串传送到系统剪贴板？
   http://www.access-cn.com/info/info2467.html
4.Access把文本框复制到剪贴板的例子
   http://www.access-cn.com/info/info1831.html
5.VBA保存剪贴板为Bmp(加PrtScrn截屏)
    http://www.access-cn.com/info/info3461.html
6.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


  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

  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

  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

  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

  14. Private Type GdiplusStartupInput
  15. GdiplusVersion As Long
  16. DebugEventCallback As Long
  17. SuppressBackgroundThread As Long
  18. SuppressExternalCodecs As Long
  19. End Type

  21. Private Type EncoderParameter
  22. GUID As GUID
  23. NumberOfValues As Long
  24. type As Long
  25. Value As Long
  26. End Type

  28. Private Type EncoderParameters
  29. Count As Long
  30. Parameter As EncoderParameter
  31. End Type

  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

  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


  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-无法打开剪贴板

  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
复制代码





收藏 分享 邀请
上一篇：求助调用和关闭外部屏幕软键盘程序的方法。下一篇：VBA中如何清空“剪切板”.

相关阅读

发表评论

最新评论

引用 t小宝 2015-4-17 23:51
好资料！
引用 玉树TMD临风 2015-7-6 00:24
这么麻烦的。

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

比如rst（"地址"）=后面怎么写？
引用 p51219 2016-7-10 00:30
好好好呵呵呵呵呵

查看全部评论(3)

相关分类

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-5-4 07:07 , Processed in 0.078657 second(s), 24 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

返回顶部