无须PictureBox的全API截屏代码

admin

1. Option Explicit
   
2. 
   
3. '//////////////////////////////////////////////////////////////////////////////
   
4. '@@summary 支持全屏截屏
   
5. '@@require 无
   
6. '@@reference 代码部分来源网络，我进行了组合构建，以及删减调试
   
7. '@@license MIT
   
8. '@@author [email protected]
   
9. '@@create 2016年4月28日14:10:43
   
10. '@@modify
    
11. '//////////////////////////////////////////////////////////////////////////////
    
12. 
    
13. '//////////////////////////////////////////////////////////////////////////////
    
14. '//
    
15. '// 私有声明
    
16. '//
    
17. '//////////////////////////////////////////////////////////////////////////////
    
18. 
    
19. '------------------------------------------------------------------------------
    
20. ' 私有数据类型
    
21. '------------------------------------------------------------------------------
    
22. Private Type GUID
    
23.     Data1 As Long
    
24.     Data2 As Integer
    
25.     Data3 As Integer
    
26.     Data4(0 To 7) As Byte
    
27. End Type
    
28. 
    
29. Private Type GdiplusStartupInput
    
30.     GdiplusVersion As Long
    
31.     DebugEventCallback As Long
    
32.     SuppressBackgroundThread As Long
    
33.     SuppressExternalCodecs As Long
    
34. End Type
    
35. 
    
36. Private Type EncoderParameter
    
37.     GUID As GUID
    
38.     NumberOfValues As Long
    
39.     Type As Long
    
40.     Value As Long
    
41. End Type
    
42. 
    
43. Private Type EncoderParameters
    
44.     Count As Long
    
45.     Parameter As EncoderParameter
    
46. End Type
    
47. 
    
48. Private Type PicBmp
    
49.     Size As Long
    
50.     Type As Long
    
51.     hbmp As Long
    
52.     hPal As Long
    
53.     Reserved As Long
    
54. End Type
    
55. 
    
56. '------------------------------------------------------------------------------
    
57. ' 私有API
    
58. '------------------------------------------------------------------------------
    
59. Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
    
60. Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    
61. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
    
62. Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    
63. Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    
64. Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    
65. Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long
    
66. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    
67. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    
68. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    
69. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    
70. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
    
71.                                                             ByVal nWidth As Long, ByVal nHeight As Long) As Long
    
72. Private Declare Function SelectObject Lib "gdi32" _
    
73.                             (ByVal hdc As Long, ByVal hObject As Long) As Long
    
74. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
    
75.                             (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
    
76.                              IPic As IPicture) As Long
    
77. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
78. 
    
79. '//////////////////////////////////////////////////////////////////////////////
    
80. '//
    
81. '// 类
    
82. '//
    
83. '//////////////////////////////////////////////////////////////////////////////
    
84. 
    
85. '------------------------------------------------------------------------------
    
86. ' 初始化
    
87. '------------------------------------------------------------------------------
    
88. Private Sub Class_Initialize()
    
89. End Sub
    
90. 
    
91. '------------------------------------------------------------------------------
    
92. ' 销毁
    
93. '------------------------------------------------------------------------------
    
94. Private Sub Class_Terminate()
    
95. End Sub
    
96. 
    
97. '//////////////////////////////////////////////////////////////////////////////
    
98. '//
    
99. '// 私有方法
    
100. '//
     
101. '//////////////////////////////////////////////////////////////////////////////
     
102. 
     
103. Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean
     
104.     Dim tSI As GdiplusStartupInput
     
105.     Dim lRes As Long
     
106.     Dim lGDIP As Long
     
107.     Dim lBitmap As Long
     
108. 
     
109.     '初始化 GDI+
     
110.     tSI.GdiplusVersion = 1
     
111.     lRes = GdiplusStartup(lGDIP, tSI, 0)
     
112.     If lRes = 0 Then
     
113.         '从句柄创建 GDI+ 图像
     
114.         lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
     
115.         If lRes = 0 Then
     
116.             Dim tJpgEncoder As GUID
     
117.             Dim tParams As EncoderParameters
     
118. 
     
119.             '初始化解码器的GUID标识
     
120.             CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
     
121.             '设置解码器参数
     
122.             tParams.Count = 1
     
123.             With tParams.Parameter ' Quality
     
124.                 '得到Quality参数的GUID标识
     
125.                 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
     
126.                 .NumberOfValues = 1
     
127.                 .Type = 4
     
128.                 .Value = VarPtr(quality)
     
129.             End With
     
130.             '保存图像
     
131.             lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
     
132.             '销毁GDI+图像
     
133.             GdipDisposeImage lBitmap
     
134.         End If
     
135.         '销毁 GDI+
     
136.         GdiplusShutdown lGDIP
     
137.     End If
     
138.     If lRes Then
     
139.         PictureBoxSaveJPG = False
     
140.     Else
     
141.         PictureBoxSaveJPG = True
     
142.     End If
     
143. End Function
     
144. 
     
145. '//////////////////////////////////////////////////////////////////////////////
     
146. '//
     
147. '// 公有方法
     
148. '//
     
149. '//////////////////////////////////////////////////////////////////////////////
     
150. 
     
151. Public Sub ClipScreenToFile(ByVal FilePath As String)
     
152.     Dim pPicture As New StdPicture
     
153.     Set pPicture = ClipToImage
     
154.     PictureBoxSaveJPG pPicture, FilePath
     
155. End Sub
     
156. 
     
157. Private Function ClipToImage() As StdPicture
     
158.     Dim screenDc As Long, width As Long, height As Long
     
159.     Dim lPicDc As Long, lPicBmp As Long
     
160.     Dim G As GUID, p As PicBmp
     
161. 
     
162.     width = Screen.width / Screen.TwipsPerPixelX
     
163.     height = Screen.height / Screen.TwipsPerPixelY
     
164.     screenDc = GetDC(0)
     
165.     lPicDc = CreateCompatibleDC(screenDc)
     
166.     lPicBmp = CreateCompatibleBitmap(screenDc, width, height)
     
167.     SelectObject lPicDc, lPicBmp
     
168.     BitBlt lPicDc, 0, 0, width, height, screenDc, 0, 0, vbSrcCopy
     
169.     With G
     
170.         .Data1 = &H20400
     
171.         .Data4(0) = &HC0&
     
172.         .Data4(7) = &H46&
     
173.     End With
     
174.     With p
     
175.         .Size = Len(p)
     
176.         .Type = vbPicTypeBitmap
     
177.         .hbmp = lPicBmp
     
178.         .hPal = &H0&
     
179.     End With
     
180.     OleCreatePictureIndirect p, G, True, ClipToImage
     
181.     ReleaseDC 0, screenDc
     
182.     DeleteObject lPicBmp
     
183. End Function

复制代码

使用方式
1、复制以上代码
2、VB6中创建一个类，删除默认的代码
3、以刚才复制的代码粘贴到新建的类中，将类命名为CScreenCliper
4、代码用法

1. Dim op As New CScreenCliper
   
2. op.ClipScreenToFile App.Path & "\demo.jpg"
   
3. Set op = Nothing

复制代码

马云爱逛京东

有个别的思路，模拟按键PrintScreen，然后读取剪贴板保存文件