|
VB 屏幕截取以及图片压缩模块：
Option Explicit
'屏幕截取以及图片压缩模块
'调用方法：If GetScrData("c:\a.jpg") = True Then MsgBox "截取并压缩成功!"
Private Type GUID '图片转换压缩处理
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal OutFile As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal OutFile As Long, Bitmap As Long) As Long 'BmpFileToJpg 用到 '图片转换压缩处理
'屏幕截取
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '获取句柄
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 '获取图片数据
Public Function GetScrData(P As String) As Boolean '获取屏幕数据并保存为图片
On Error GoTo Over
Form1.BorderStyle = 2 '窗体风格,否则截取不全
Form1.AutoRedraw = True '开启自动重绘
BitBlt Form1.hDC, 0, 0, Screen.Width, Screen.Height, GetDC(0), 0, 0, vbSrcCopy '截取图片
SavePicture Form1.Image, P & ".B" '保存为图片,覆盖模式
If BmpFileToJpg(P & ".B", P, 100) = True Then GetScrData = True 'Bmp文件路径,Jpg文件路径,图片质量:100(默认:80)'获取成功
If Dir(P & ".B", vbHidden + vbReadOnly + vbSystem) <> "" Then Kill P & ".B" '删除临时文件
Exit Function '结束过程
Over:
GetScrData = False '获取失败
End Function
Public Function BmpFileToJpg(ByVal BmpFile As String, ByVal OutFile As String, Optional ByVal Quality As Byte = 80) As Boolean 'Bmp文件转换为Jpg文件:Bmp文件路径,Jpg文件路径,图片质量(默认:80)
On Error GoTo Over
Dim TSI As GdiplusStartupInput, LRes As Long, lGDIP As Long, lBitmap As Long
TSI.GdiplusVersion = 1 '初始化 GDI+
LRes = GdiplusStartup(lGDIP, TSI, 0)
If LRes = 0 Then
LRes = GdipCreateBitmapFromFile(StrPtr(BmpFile), lBitmap) '从句柄创建 GDI+ 图像
If LRes = 0 Then
Dim tJpgEncoder As GUID, tParams As EncoderParameters
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder '初始化解码器的GUID标识
tParams.Count = 1 '设置解码器参数
With tParams.Parameter '图片质量
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID '得到Quality参数的GUID标识
.NumberOfValues = 1
.type = 4
.Value = VarPtr(Quality)
End With
LRes = GdipSaveImageToFile(lBitmap, StrPtr(OutFile), tJpgEncoder, tParams) '保存图像
GdipDisposeImage lBitmap '销毁GDI+图像
End If
GdiplusShutdown lGDIP '销毁 GDI+
End If
If LRes Then BmpFileToJpg = False Else BmpFileToJpg = True '判断执行成功还是失败
Exit Function '退出过程
Over:
BmpFileToJpg = False '执行失败
End Function |