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

Question

我的程序的目的是 从屏幕上不同位置截了两张图 逐个象素分析 不同的涂红 现在这个程序对于用picture属性载入的图片是可以工作的 但是要复制截图就要用到bitblt 这是复制到picture还是image啊?总之对于bitblt到的图片一点效果都没有
下面是主要程序 请帮帮忙看看哪里不对 ，要不然就只能用缓慢的point和pset了Dim ix As Integer
Dim iy As Integer
Dim iWidth As Integer '以像素为单位的图形宽度
Dim iHeight As Integer '以像素为单位的图形高度
Dim bits() As Byte '存放图1
Dim bitsBW() As Byte ''存放图2
    ScrHwnd = GetDesktopWindow()
    '得到DC设备句柄
    ScrDc = GetDC(ScrHwnd)
    Picture1.Cls
    Picture2.Cls
 BitBlt Picture1.hdc, 0, 0, 500, 452, ScrDc, 7, 189, vbSrcCopy
BitBlt Picture2.hdc, 0, 0, 500, 452, ScrDc, 516, 189, vbSrcCopy
Picture2.Picture = Picture2.Image
Picture1.Picture = Picture1.ImagePicture1.Refresh
iWidth = 500
iHeight = 452
Dim bi24BitInfo As BitMapInfo
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = iWidth
.biHeight = Picture1.ScaleHeight / Screen.TwipsPerPixelY
End WithReDim bits(3, 0 To iWidth, 0 To iHeight) As Byte'图1
ReDim bitsBW(3, 0 To iWidth, 0 To iHeight) As Byte'图2lrtn = GetDIBits(Picture1.hdc, Picture1.Picture.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, 0&)
lrtn2 = GetDIBits(Picture2.hdc, Picture2.Picture.Handle, 0&, iHeight, bitsBW(0, 0, 0), bi24BitInfo, 0&)
'获取图形的宽度和高度
For ix = 0 To iWidth
For iy = 0 To iHeightIf RGB(bits(2, ix, iy), bits(1, ix, iy), bits(0, ix, iy)) <> RGB(bitsBW(2, ix, iy), bitsBW(1, ix, iy), bitsBW(0, ix, iy)) Then
bits(2, ix, iy) = 255'逐个象素比较
bits(1, ix, iy) = 0
bits(0, ix, iy) = 0
End If
Next
Next
Picture1.Picture = Picture1.Image
Picture1.Refresh
 SetDIBits Picture1.hdc, Picture1.Picture.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, 0&
 Picture1.Picture = Picture1.Image
Picture2.Refresh

Answer 1

BITMAPINFOHEADER的biBitCount设成24就行，32位的BitBlt好像不支持。改动后的24位位图，宽度（像素单位）和每行的字节数的计算式是：cbScanLine = (cx * 3 + 3) And &HFFFFFFFCbits()的第一维和第二维需要改动。

Answer 2

多谢二楼的 现在还是不行啊 
我把biBitCount改成了24 出来的东西就是一行一行的了 另外 您说的bits的第一维和第二微需要做什么改变呢？谢谢
我贴出来 是这样的 改过之后
iWidth = Picture1.ScaleWidth / Screen.TwipsPerPixelX
iHeight = Picture1.ScaleHeight / Screen.TwipsPerPixelYDim bi24BitInfo As BitMapInfo
With bi24BitInfo.bmiHeader
.biBitCount = 24
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = iWidth
.biHeight = iHeight
   LineBytes = (iWidth * 3 + 3) And &HFFFFFFFC
   .biSizeImage = LineBytes * iHeight
End With
ReDim bits(3, 0 To iWidth, 0 To iHeight) As Byte
ReDim bitsBW(3, 0 To iWidth, 0 To iHeight) As Bytelrtn = GetDIBits(Picture1.hdc, Picture1.Picture.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, 0&)
lrtn2 = GetDIBits(Picture2.hdc, Picture2.Picture.Handle, 0&, iHeight, bitsBW(0, 0, 0), bi24BitInfo, 0&)原来32的时候是涂红的..（不知道是不是图像没有读到）..结果现在变成了全部的有间隔的黑色竖线

Answer 3

不喜欢看别人的代码，给你写了一段屏幕抓图，然后GetDIBits获取像素，然后逐像素遍历，灰化显示在PictureBox上的代码。
最后显示用的是StretchDIBits，也可以把位图选入场景，用BitBlt显示，一样的。自己研究吧。Option ExplicitPrivate 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 TypePrivate 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