截屏后保存为图片的VBA语句

刘雄军

截屏的语言已有，就是不知道怎么另存为图片：路径为：D:\2.jpg
截屏.zip (110.33 KB, 下载次数: 577)

2015-3-20 20:35 上传

点击文件名下载附件

刘雄军

没有帮我呀，求高手出现

wcymiss

下面这段代码不太精确：

1. Sub Test()
   
2.     With ActiveSheet.ChartObjects.Add(0, 0, 800, 500)
   
3.         .Chart.Paste
   
4.         .Chart.Export filename:="D:\2.jpg", FilterName:="JPG"
   
5.         .Delete
   
6.     End With
   
7. End Sub

复制代码

如果要精确的图片，需要用到API：

1. 
   
2. '剪贴板函数
   
3. Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
   
4. Private Declare Function CloseClipboard Lib "user32" () As Long
   
5. Private Declare Function GetClipboardData Lib "user32" (ByVal Format As Long) As Long
   
6. 
   
7. 'OLE函数
   
8. Private Type Clsid
   
9.    Data1 As Long
   
10.    Data2 As Integer
    
11.    Data3 As Integer
    
12.    Data4(0 To 7) As Byte
    
13. End Type
    
14. 
    
15. Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As Clsid) As Long
    
16. 
    
17. 'GDI函数
    
18. Private Type GdiplusStartupInput
    
19.    GdiplusVersion As Long
    
20.    DebugEventCallback As Long
    
21.    SuppressBackgroundThread As Long
    
22.    SuppressExternalCodecs As Long
    
23. End Type
    
24. 
    
25. Private Type EncoderParameter
    
26.    Guid As Clsid
    
27.    NumberOfValues As Long
    
28.    type As Long
    
29.    value As Long
    
30. End Type
    
31. 
    
32. Private Type EncoderParameters
    
33.    count As Long
    
34.    Parameter As EncoderParameter
    
35. End Type
    
36. 
    
37. Private Const CLSID_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
    
38. Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
    
39. 
    
40. Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    
41. Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    
42. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As Long
    
43. Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
    
44. Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As Clsid, encoderParams As Any) As Long
    
45. 
    
46. Sub ClipboardBmpToJPGFile() '剪贴板图片保存JPG文件
    
47.     Dim hMem As Long
    
48.     Dim bitmap As Long
    
49.     Dim GDI_Token As Long
    
50.     Dim GpInput As GdiplusStartupInput
    
51.     Dim ReturnValue As Long
    
52.     Dim Params As EncoderParameters
    
53.     Dim Quality As Long
    
54.    
    
55.     '获取剪贴板BMP数据的Handle
    
56.     OpenClipboard 0&
    
57.     hMem = GetClipboardData(2)
    
58.     CloseClipboard
    
59.     If hMem = 0 Then MsgBox "未找到截屏数据": Exit Sub
    
60.    
    
61.     '初始化GDI+
    
62.     GpInput.GdiplusVersion = 1
    
63.     ReturnValue = GdiplusStartup(GDI_Token, GpInput)
    
64.     If ReturnValue <> 0 Then MsgBox "初始化GDI+失败！": Exit Sub
    
65.    
    
66.     '创建GDI+的bitmap对象
    
67.     GdipCreateBitmapFromHBITMAP hMem, 0, bitmap
    
68.    
    
69.     'JPG压缩参数设置
    
70.     Quality = 50
    
71.     With Params
    
72.         .count = 1
    
73.         With .Parameter
    
74.             .Guid = GetEncoderClsid(EncoderQuality)
    
75.             .NumberOfValues = 1
    
76.             .type = 4
    
77.             .value = VarPtr(Quality)
    
78.         End With
    
79.     End With
    
80. 
    
81.     GdipSaveImageToFile bitmap, StrPtr("D:\Test\2.jpg"), GetEncoderClsid(CLSID_JPG), Params
    
82.    
    
83.     GdipDisposeImage bitmap
    
84.     GdiplusShutdown GDI_Token
    
85. End Sub
    
86. 
    
87. Private Function GetEncoderClsid(CLSIDString As String) As Clsid
    
88.     CLSIDFromString StrPtr(CLSIDString), GetEncoderClsid
    
89. End Function

复制代码

yf_home

wcymiss 发表于 2015-4-1 15:45
下面这段代码不太精确：如果要精确的图片，需要用到API：

吴姐，用API截屏，保存后的图片，边框不完整(上边、左边)。
如图：

wcymiss

yf_home 发表于 2015-4-1 16:13
吴姐，用API截屏，保存后的图片，边框不完整(上边、左边)。
如图：

你复制的代码是什么？或者，你是怎样复制的？

我这边手动复制（ctrl+C）单元格(A1:B2)，然后运行代码，保存后的图片边框齐全的。

yf_home

wcymiss 发表于 2015-4-1 16:28
你复制的代码是什么？或者，你是怎样复制的？

我这边手动复制（ctrl+C）单元格(A1:B2)，然后运行代码， ...

就是这样操作的。

yf_home

wcymiss 发表于 2015-4-1 16:28
你复制的代码是什么？或者，你是怎样复制的？

我这边手动复制（ctrl+C）单元格(A1:B2)，然后运行代码， ...

如果是软件的问题，先忽略。
那插入到工作表，也是显示不全的。
我录制个动画，看看效果：

wcymiss

yf_home 发表于 2015-4-1 17:02
如果是软件的问题，先忽略。
那插入到工作表，也是显示不全的。
我录制个动画，看看效果：

分别测试了两种复制单元格形成BMP数据的方式（Range("B4:C7").Copy 和  Range("B4:C7").CopyPicture xlScreen, xlBitmap），发现剪贴板中BMP格式的颜色数据，确实没有上左边框，最上一行和最左一列的颜色均为白色。（之前我看到的上左边框应该是图片软件的图片框）。

数据到剪贴板的时候已经没有边框了。。。

其实3楼代码的效果跟复制单元格到QQ聊天窗口然后保存为图片的效果是一样的。复制到聊天窗口的图片也没有左上边框。

jpj123

wcymiss 发表于 2015-4-1 15:45
下面这段代码不太精确：如果要精确的图片，需要用到API：

好长一段代码，老师费心，收藏起来慢慢学习。

yf_home

wcymiss 发表于 2015-4-1 19:29
分别测试了两种复制单元格形成BMP数据的方式（Range("B4:C7").Copy 和  Range("B4:C7").CopyPicture xl ...

有没有办法解决？


.