看看我的方法为什么显示不出来 SetDIBits

Option Explicit



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 GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private 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

Private Type RGBQUAD

        rgbBlue As Byte

        rgbGreen As Byte

        rgbRed As Byte

        rgbReserved As Byte

End Type



Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Type BITMAP '14 bytes

        bmType As Long

        bmWidth As Long

        bmHeight As Long

        bmWidthBytes As Long

        bmPlanes As Integer

        bmBitsPixel As Integer

        bmBits As Long

End Type

Private Type BITMAPINFO

        bmiHeader As BITMAPINFOHEADER

        bmiColors As RGBQUAD

End Type

Private Const BI_RGB = 0&

Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Const DIB_RGB_COLORS = 0 '  color table in RGBs

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 Type RECT

        Left As Long

        Top As Long

        Right As Long

        Bottom As Long

End Type

Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long





Private Sub Command1_Click()

    Dim rcSnap As RECT

    

    Dim hDCDst As Long

    Dim rectDst As RECT

    Dim hBmpSrc As Long

    Dim hDCSrc As Long

    Dim hBmpOri As Long

    Dim hDCScreen As Long

    

    Call SetRect(rcSnap, 500, 100, 800, 300)

    hDCDst = Picture1.hdc

    

    hDCScreen = GetDC(0)

    hDCSrc = CreateCompatibleDC(hDCScreen)

    hBmpSrc = CreateCompatibleBitmap(hDCScreen, rcSnap.Right - rcSnap.Left, rcSnap.Bottom - rcSnap.Top)

    hBmpOri = SelectObject(hDCSrc, hBmpSrc)

    Call BitBlt(hDCSrc, 0, 0, rcSnap.Right - rcSnap.Left, rcSnap.Bottom - rcSnap.Top, hDCScreen, rcSnap.Left, rcSnap.Top, vbSrcCopy)

    Call ReleaseDC(0, hDCScreen)

    Call SelectObject(hDCSrc, hBmpOri)

    Call DeleteDC(hDCSrc)

    

    '获得源位图属性

    Dim bmp As BITMAP

    Call GetObject(hBmpSrc, Len(bmp), bmp)



    ' 源位图像素位转换为 DIB

    Dim bmpinfo As BITMAPINFO

    With bmpinfo.bmiHeader

        .biSize = Len(bmpinfo.bmiHeader)

        .biWidth = bmp.bmWidth

        .biHeight = bmp.bmHeight

        .biPlanes = 1

        .biBitCount = 24

        .biCompression = BI_RGB

    End With

    

    Dim cbPerLine As Long

    cbPerLine = (bmp.bmWidth * 3 + 3) And &HFFFFFFFC



    Dim bBits() As Byte

    ReDim bBits(cbPerLine - 1, bmp.bmHeight - 1) As Byte

    Call GetDIBits(hDCDst, hBmpSrc, 0, bmp.bmHeight, ByVal VarPtr(bBits(0, 0)), bmpinfo, DIB_RGB_COLORS)

    Call DeleteObject(hBmpSrc)

    

    '把每个像素设置为灰色值

    Dim bGray As Integer

    Dim i As Long, j As Long, k As Long

    For j = 0 To bmp.bmHeight - 1

        For i = 0 To bmp.bmWidth - 1

            k = i * 3

            bGray = (CLng(bBits(k, j)) * 29 + CLng(bBits(k + 1, j)) * 150 + CLng(bBits(k + 2, j)) * 77 + 128) / 256

            If bGray > 255 Then

                bGray = 255

            End If

            bBits(k, j) = bGray

            bBits(k + 1, j) = bGray

            bBits(k + 2, j) = bGray

        Next i

    Next j

 

    '将设好的位绘制到目标 DC

    Call SetRect(rectDst, 0, 0, bmp.bmWidth, bmp.bmHeight)

    Call StretchDIBits(hDCDst, rectDst.Left, rectDst.Top, rectDst.Right - rectDst.Left, rectDst.Bottom - rectDst.Top, 0, 0, bmp.bmWidth, bmp.bmHeight, ByVal VarPtr(bBits(0, 0)), bmpinfo, DIB_RGB_COLORS, vbSrcCopy)

    Set Picture1.Picture = Picture1.Image

End Sub