VB截取屏幕并保存jpg格式源码（重点在于修复bug）

seemk

前两天一直好奇，不借助第三方库的情况下怎么实现转换jpg格式图片呢（自己写压缩算法实在太难了），后来无意中搜索到了一段VB的代码，复制下来可以使用，原理是调用gdiplus.dll（几乎所有系统都有这个dll），但是有一个很诡异的问题：调试的时候压缩率可以正常使用，而生成的exe却不能正常使用压缩率这个参数，每次都是100%存储，占用空间很大。先把有问题的代码贴出来，稍后我做修复。

[Visual Basic] 纯文本查看 复制代码

Option Explicit

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 GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap 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 FileName 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 FileName As Long, Bitmap As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function AbortDoc Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject 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

Private Function HBmp2JPG(ByVal hBmp As Long, ByVal FileName As String, Optional ByVal quality As Byte = 80) As Boolean
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    
    '初始化 GDI+
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI, 0)
     
    If lRes = 0 Then
        '从句柄创建 GDI+ 图像
        lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            '初始化解码器的GUID标识
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             
            '设置解码器参数
            tParams.Count = 1
            With tParams.Parameter ' Quality
               '得到Quality参数的GUID标识
               CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
               .NumberOfValues = 1
               .type = 4
               .Value = VarPtr(quality)
            End With
            MsgBox tParams.Parameter.Value
            '保存图像
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
            '销毁GDI+图像
            GdipDisposeImage lBitmap
        End If
        '销毁 GDI+
        GdiplusShutdown lGDIP
    End If
    HBmp2JPG = IIf(lRes, False, True)
End Function

Sub CaptureScreen(FileName As String)
    Dim hDC As Long
    Dim hDCmem As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    hDC = GetDC(0)
    hDCmem = CreateCompatibleDC(hDC)
    hBmp = CreateCompatibleBitmap(hDC, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
    hBmpPrev = SelectObject(hDCmem, hBmp)
    BitBlt hDCmem, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, hDC, 0, 0, vbSrcCopy
    SelectObject hDCmem, hBmpPrev
    DeleteDC hDCmem
    ReleaseDC 0, hDC
    If HBmp2JPG(hBmp, FileName, 10) Then
        MsgBox "抓屏成功，JPG文件保存在" & FileName
    Else
        MsgBox "抓屏失败"
    End If
    DeleteObject hBmp
End Sub

Private Sub Command1_Click()
    CaptureScreen "c:\test.jpg"
End Sub

像调试程序和最终生成程序出现差异的问题还是比较头疼，尤其是VB这种特殊编译方式的代码很难用OD逆向分析，于是不得不用msgbox来逐一输出可能出错的变量值（或变量地址再用CE查看其值），当查看到Private Function HBmp2JPG(ByVal hBmp As Long, ByVal FileName As String, Optional ByVal quality As Byte = 80) As Boolean这个函数时发现quality参数的值在传递给API前是正常的，但是传递给结构体tParams时出现问题，值不相等。想了想，恍然大悟，tParams结构体中是整形4字节的，而这里参数给的是1字节Byte型的，tParams因为没有初始化，所以在栈中是垃圾数据（调试的时候初始化为0，这就是差异所在），所以导致压缩率这个参数大于了100.这样的话只要把As Byte改成As Long就行了（不要用int，VB里的int为2字节）。
大家复制下来自己改下就行了，或者下载我打包好的工程文件，懒得传网盘了，需要的朋友还是从论坛下载吧：
截屏jpg.zip (7.46 KB, 下载次数: 53)

2015-4-21 16:02 上传

点击文件名下载附件

qscb001

好软件，用用啊

s1986q

谢谢楼主分享源代码。

sugarnice

学习辣，现处于 入门阶段呢

ppszxc

不错，赞一个，不过截图不太清晰

Wannxy

好厉害 但是还是不知道TPYE 怎么用不知道楼主看能能不能给说下。