截取全屏并保存到BMP的模块

'关键在于输出到文件的时候，既然可以得到二进制数组了，就可以做很多事情了，哈哈
'可以压缩数组 / 可以转换成JPG / 可以保存到剪贴板 。。。。。。

Option Explicit

Public Type BITMAPFILEHEADER
                bfType(0 To 1)       As Byte
                bfSize   As Long
                bfReserved1   As Integer
                bfReserved2   As Integer
                bfOffBits   As Long
End Type

Public Type BITMAPINFOHEADER       '"40   bytes
                biSize   As Long
                biWidth   As Long
                biHeight   As Long
                biPlanes   As Integer
                biBitCount   As Integer
                biCompression   As Long
                biSizeImage   As Long
                biXPelsPerMeter   As Long
                biYPelsPerMeter   As Long
                biClrUsed   As Long
                biClrImportant   As Long
End Type
Public Type RGBQUAD
                rgbBlue   As Byte
                rgbGreen   As Byte
                rgbRed   As Byte
                rgbReserved   As Byte
End Type
Public Type BITMAPINFO
                bmiHeader   As BITMAPINFOHEADER
                bmiColors   As RGBQUAD
End Type

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
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
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Public Const DIB_RGB_COLORS = 0          ' "     color   table   in   RGBs
Public Const SRCCOPY = &HCC0020           '"   (DWORD)   dest   =   source

Public Function CopyScreenToBMP(ByVal szfile As String) As Boolean
    Dim w     As Long, h       As Long
    Dim scrDC     As Long
    Dim DIB     As Long, m_DC       As Long
    Dim BmpInfo     As BITMAPINFO
    Dim BmpFileHead     As BITMAPFILEHEADER
    Dim pData     As Long
    Dim buff()     As Byte
    Dim old     As Long
    Dim L     As Long
        '"取屏幕   高宽
        w = Screen.Width / 15
        h = Screen.Height / 15
        '"准备内存DC
        m_DC = CreateCompatibleDC(0&)
        If m_DC = 0 Then
                CopyScreenToBMP = False
                Exit Function
        End If
        '"填充DIB的BMP结构
        With BmpInfo.bmiHeader
                .biBitCount = 24
                .biPlanes = 1
                .biHeight = h
                .biWidth = w
                .biSize = 40       '"本结构长度
        End With
       
        DIB = CreateDIBSection(m_DC, BmpInfo, DIB_RGB_COLORS, pData, 0, 0)
        '"分配内存
        If DIB = 0 Then
                CopyScreenToBMP = False
                Exit Function
        End If
       
        old = SelectObject(m_DC, DIB)
        '"拷屏
        scrDC = GetDC(0)
        BitBlt m_DC, 0, 0, w, h, scrDC, 0, 0, SRCCOPY
       
        '"分配内存
        L = w * h * 3
        '"补足4的倍数
        If L Mod 4 <> 0 Then L = L + (4 - L Mod 4)
        ReDim buff(1 To L) As Byte
       
       
        '"取像素数据
        CopyMemory VarPtr(buff(1)), pData, L
       
        '"释放资源
        SelectObject m_DC, old
        DeleteObject DIB
        DeleteDC m_DC
       
        '"填充BMPFILE
        With BmpFileHead
                '"BM标志
                .bfType(0) = Asc("B"):       .bfType(1) = Asc("M")
                .bfSize = Len(BmpFileHead) + Len(BmpInfo) + L
                .bfOffBits = Len(BmpFileHead) + Len(BmpInfo)
        End With
       
        '"写入文件
       
        L = FreeFile()
        Open szfile For Binary As L
        '"写入文件头
        Put L, , BmpFileHead
        Put L, , BmpInfo
        '"写入实际像素
        Put L, , buff()
        Close L
       
        CopyScreenToBMP = True

End Function