【找圖演算法! GetDIBits獲取螢屏色值】貼完整代碼，求解幾個問題，冰天雪地跪求大神指點！！！-有解無憂

各位老師好

這個代碼我處理了6個小時還是無法排錯, 無可奈何了只能到論壇求助, 希望您能幫幫我!
(我是業余自學的不是專業大神但是覺得編程能極大減少人類勞動)

現在只有45分真實抱歉-_-|||

這個代碼實作的是GetDIBits獲取螢屏色值, 我的螢屏是1280*1024(是的單位顯示幕就是這么小!),

但是它有一個問題:
LeftSrc As Long, RightSrc As Long, TopSrc As Long, BttnSrc As Long
設定為 0, 0, 200, 100
或者: 100, 100, 300, 200

這樣的前面連個引數小的話, 是沒有問題的, 但是
前面兩個引數大了, 比如是設定為1200,1279,1000,1023, 就會獲取不到色值!

不知道是什么原因!
另外前兩個引數比如設定為800,600的話就是獲取到螢屏最右下角的一小部分的色值了
即獲取的不是800,600的其實位置而是更遠的位置

因為內功淺, 代碼并沒有完全理解, 所以無法知曉出錯的原因, 求老師教導啊!!

我很希望能完全理解這些代碼的意思, 但是沒有注解, 或許有注解我也不能完全明白, 因為知識上還有基礎沒有學

另外關于位圖的知識我還幾乎沒有什么了解, 請問微微老師有什么資料推薦下我學習嗎?

再然后我的找圖用這個代碼不夠快, 有的代碼能40微秒找到圖, 我寫的要慢10倍, 不知道有什么方法或者演算法能實作最快的找圖呢? 因為這個獲取色值也要40到60微秒了. 難道那些40微秒左右找到圖的是用顯卡GPU進行多區域同時找圖這樣的并行運算了嗎OMG!

下面貼上完整代碼！（VB FORM1要加上picture1, command1）

Option Explicit

Private Type RGBQUAD

 rgbBlue As Byte

 rgbGreen As Byte

 rgbRed As Byte

 rgbAlpha As Byte       '透明通道

End Type



Private Type BITMAPINFOHEADER

 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 BITMAPINFO

 bmiHeader As BITMAPINFOHEADER

 bmiColors As RGBQUAD

End Type



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 Declare Function GetWindowDC Lib "user32" (ByVal hwnd 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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 Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long





Private Const BI_RGB = 0&











Private Type POINTAPI

  x As Long

  y As Long

End Type



Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long



Dim P As POINTAPI







Private Sub Command1_Click()

  

 'Call 獲取螢屏色值(ByVal還是ByRef a, ByVal b, ByVal c, ByVal d)



  Call 獲取螢屏色值



End Sub











Private Sub 獲取螢屏色值() '(LeftSrc As Long, RightSrc As Long, TopSrc As Long, BttnSrc As Long)



Dim t As Single, t2 As Single

t = Timer



Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, r As Long

Dim hDCSrc As Long, hPal As Long, hPalPrev As Long

Dim LeftSrc As Long, TopSrc As Long, RightSrc As Long, BttnSrc As Long

Dim bytDataOut() As Byte, lngOut() As Long

Dim BitInfo As BITMAPINFO

Dim i As Long, j As Long

Dim hWndSrc As Long 









'修改下面4個引數就可以調整畫面范圍

   LeftSrc = 1100    'X

RightSrc = 1279  ' X



 TopSrc = 1000     'Y

 BttnSrc = 1023     'Y









hDCSrc = GetWindowDC(0) '(hWndSrc)

hDCMemory = CreateCompatibleDC(hDCSrc)

hBmp = CreateCompatibleBitmap(hDCSrc, RightSrc, BttnSrc)

hBmpPrev = SelectObject(hDCMemory, hBmp)

r = BitBlt(hDCMemory, 0, 0, RightSrc, BttnSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)  ' <--這里有問題嗎?





ReDim bytDataOut(2, RightSrc - 1, BttnSrc - 1) ' <--這里有問題嗎?

ReDim lngOut(RightSrc - 1, BttnSrc - 1)            '<--這里有問題嗎?



With BitInfo.bmiHeader

.biBitCount = 24                                               '<--這里有問題嗎?

.biCompression = BI_RGB '0

.biPlanes = 1

.biSize = Len(BitInfo.bmiHeader)

.biWidth = RightSrc

.biHeight = -BttnSrc

End With



GetDIBits hDCMemory, hBmp, 0, BttnSrc, bytDataOut(0, 0, 0), BitInfo, BI_RGB '0

hBmp = SelectObject(hDCMemory, hBmpPrev)

r = DeleteDC(hDCMemory)

r = ReleaseDC(hWndSrc, hDCSrc)

DeleteObject hBmp







t2 = Timer - t





For i = LeftSrc To RightSrc - 1

 For j = TopSrc To BttnSrc - 1

  lngOut(i, j) = RGB(bytDataOut(2, i, j), bytDataOut(1, i, j), bytDataOut(0, i, j))

 Next

Next





Form1.Label1 = "資料已存放在lngOut陣列里面" & "||" & t2 & "||" & Timer - t 'MsgBox "資料已存放在lngOut陣列里面" & lngOut(5, 5) & "||" & t2 & "||" & Timer - t

Picture1.AutoRedraw = True

Picture1.ScaleMode = 3 





Dim ii&, jj&



For ii = LeftSrc To RightSrc - 1  'X軸

 For jj = TopSrc To BttnSrc - 1   'Y軸

   

   Picture1.PSet (ii - LeftSrc, jj - TopSrc), lngOut(ii, jj)

   'Picture1.PSet (ii, jj), lngOut(ii, jj)

   

 Next

Next





End Sub

uj5u.com熱心網友回復：

(LeftSrc,TopSrc)=(1100,1000) 是截圖的左上角坐標
(RightSrc,BttnSrc)=(1279,1023) 接截圖的寬和高而不是右下角坐標。
早就越界了。

uj5u.com熱心網友回復：

(LeftSrc,TopSrc)=(1100,1000) 是截圖的左上角坐標
(RightSrc,BttnSrc)=(1279,1023) 是截圖的寬和高而不是右下角坐標。
早就越界了。

uj5u.com熱心網友回復：

參考 1 樓 Tiger_Zhao 的回復:

(LeftSrc,TopSrc)=(1100,1000) 是截圖的左上角坐標
(RightSrc,BttnSrc)=(1279,1023) 接截圖的寬和高而不是右下角坐標。
早就越界了。

您好!! 確實是我理解錯這里了!! 但是修改回來代碼還是無法正常截圖到螢屏右下角哦

比如這樣傳遞:

(LeftSrc,TopSrc)=(1100,1000)
(RightSrc,BttnSrc)=(100,80) '<--謝謝您的提醒這里應該是長和寬的而不是右下的坐標嗎?

uj5u.com熱心網友回復：

給你個 API-Guide 的例子

Private Const BI_RGB = 0&

Private Const DIB_RGB_COLORS = 0 '  color table in RGBs

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

        bmiHeader As BITMAPINFOHEADER

        bmiColors As RGBQUAD

End Type

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

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

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 Declare Function SetDIBitsToDevice 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 Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 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 Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Dim iBitmap As Long, iDC As Long

Private Sub Form_Paint()

    'KPD-Team 2000

    'URL: http://www.allapi.net/

    'E-Mail: [email protected]

    '-> Compile this code for better performance

    Dim bi24BitInfo As BITMAPINFO, bBytes() As Byte, Cnt As Long

    With bi24BitInfo.bmiHeader

        .biBitCount = 24

        .biCompression = BI_RGB

        .biPlanes = 1

        .biSize = Len(bi24BitInfo.bmiHeader)

        .biWidth = 100

        .biHeight = 100

    End With

    ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3) As Byte

    iDC = CreateCompatibleDC(0)

    iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)

    SelectObject iDC, iBitmap

    BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, GetDC(0), 0, 0, vbSrcCopy

    GetDIBits iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS

    For Cnt = LBound(bBytes) To UBound(bBytes)

        If bBytes(Cnt) < 50 Then

            bBytes(Cnt) = 0

        Else

            bBytes(Cnt) = bBytes(Cnt) - 50

        End If

    Next Cnt

    SetDIBitsToDevice Me.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS

    DeleteDC iDC

    DeleteObject iBitmap

End Sub

uj5u.com熱心網友回復：

參考 4 樓 Tiger_Zhao 的回復:

給你個 API-Guide 的例子
[/code]

非常感謝您的回復! 我覺得你能幫我看看問題出在哪里嗎?我今天有測驗了一下午, 代碼修改如下,

其實基本運行是沒問題的偶爾就會出錯!! 求解決啊!! 這對我是個迷啊好像解謎啊!!!

新代碼如下:

Option Explicit

Private Type RGBQUAD

 rgbBlue As Byte

 rgbGreen As Byte

 rgbRed As Byte

 rgbAlpha As Byte       '透明通道

End Type



Private Type BITMAPINFOHEADER

 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 BITMAPINFO

 bmiHeader As BITMAPINFOHEADER

 bmiColors As RGBQUAD

End Type



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 Declare Function GetWindowDC Lib "user32" (ByVal hwnd 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop 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 Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long





Private Const BI_RGB = 0&







Private Sub 獲取螢屏色值(LeftSrc As Long, WidthSrc As Long, TopSrc As Long, HeightSrc As Long)



Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, r As Long

Dim hDCSrc As Long, hPal As Long, hPalPrev As Long

Dim bytDataOut() As Byte, lngOut() As Long

Dim BitInfo As BITMAPINFO

Dim x As Long, y As Long

Dim hWndSrc As Long 



hDCSrc = GetWindowDC(0) '(hWndSrc)

hDCMemory = CreateCompatibleDC(hDCSrc)

hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)

hBmpPrev = SelectObject(hDCMemory, hBmp)

r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy) 'CNM!!!!



ReDim bytDataOut(2, WidthSrc - 1, HeightSrc - 1)

ReDim lngOut(WidthSrc - 1, HeightSrc - 1)



With BitInfo.bmiHeader

.biBitCount = 24

.biCompression = BI_RGB '0

.biPlanes = 1

.biSize = Len(BitInfo.bmiHeader)

.biWidth = WidthSrc

.biHeight = -HeightSrc

End With



GetDIBits hDCMemory, hBmp, 0, HeightSrc, bytDataOut(0, 0, 0), BitInfo, BI_RGB '0



hBmp = SelectObject(hDCMemory, hBmpPrev) 

r = DeleteDC(hDCMemory)

r = ReleaseDC(hWndSrc, hDCSrc)

DeleteObject hBmp









Picture1.AutoRedraw = True

Picture1.ScaleMode = 3 





For x = 0 To WidthSrc - 1

 For y = 0 To HeightSrc - 1

  

  lngOut(x, y) = RGB(bytDataOut(2, x, y), bytDataOut(1, x, y), bytDataOut(0, x, y))

    

    Picture1.PSet (x, y), lngOut(x, y)

    

 Next

Next







End Sub









Private Sub Command1_Click()                     

                   'LeftSrc, WidthSrc, TopSrc, HeightSrc

   Call 獲取螢屏色值(1200, 79, 900, 123)

                   

                   

                   '(100, 500, 100, 400) 這樣可以 下面卻不行

                   '(100, 1069, 100, 813) 和下面一樣

                   '(10, 1269, 10, 1013) 灰色 變傾斜!!

                   '(0, 1279, 0, 1023) 全黑!!

                   '(579, 700, 500, 523)

                   '(579, 700, 500, 523) 通過!! 下面是小學生算錯數!!!!!!!!

                   '(589, 700, 500, 523) 通過!!!!! 但是有黑邊

                   '(541, 700, 500, 523) 通過!!

                   '(500, 740, 500, 523) <--OK!! 741就錯!! 1240就極限?? 不是應該1279嗎!!

                   '(1000, 200, 873, 150)

                   

End Sub

uj5u.com熱心網友回復：

50 50 50 50用這4個也奔潰!!

非常奇怪!! 求解各位老師這是為什么呢? 我看著代碼實在發現不了問題啊!!

uj5u.com熱心網友回復：

崩潰的時候在彈出的對話框按相應按鈕進入除錯，按Alt+7鍵查看Call Stack即“呼叫堆疊”里面從上到下列出的對應從里層到外層的函式呼叫歷史。雙擊某一行可將游標定位到此次呼叫的源代碼或匯編指令處，看不懂時雙擊下一行，直到能看懂為止。

uj5u.com熱心網友回復：

參考 7 樓 zhao4zhong1 的回復:

崩潰的時候在彈出的對話框按相應按鈕進入除錯，按Alt+7鍵查看Call Stack即“呼叫堆疊”里面從上到下列出的對應從里層到外層的函式呼叫歷史。雙擊某一行可將游標定位到此次呼叫的源代碼或匯編指令處，看不懂時雙擊下一行，直到能看懂為止。

哇!!! 一直不知道有這個功能的!!! 慚愧啊!!

好高深的感徑訓編還沒有學過哦!!

我剛剛試了一下不可以, 提示記憶體不能讀為read然后按ALT+7沒有反應, 按確定VB6就奔潰掉了~

我以為我只知道高級代碼就可以了, 就退第一次聽到高手和我說匯編!

請問您能試試嗎我剛剛發現了截圖很小的話就會出錯! 長和寬大就不會出錯!

uj5u.com熱心網友回復：

在WinDbg里面運行你的VB6編譯生成的exe檔案（注意要生成本機代碼，不要生成P代碼）
崩潰的時候，使用k命令查看Call Stack

uj5u.com熱心網友回復：

函式或程序名字別用漢字。

注意每行像素資料的位元組數是按4位元組對齊的。也就是說，位元組數不到4的倍數，會額外添加1或2或3個位元組。

uj5u.com熱心網友回復：

或者一句對一句改寫為CPP，在VC IDE下除錯。
檢查每個API的回傳值。必要時GetLastError

uj5u.com熱心網友回復：

參考 9 樓 zhao4zhong1 的回復:

在WinDbg里面運行你的VB6編譯生成的exe檔案（注意要生成本機代碼，不要生成P代碼）
崩潰的時候，使用k命令查看Call Stack

太強了! 我只學過VBA和VB而已好厲害啊很多東西都是第一次聽到!!

看來我要自己解決需要多學個幾年啊!!

uj5u.com熱心網友回復：

用這個方法確實可以高速讀取螢屏圖片然后比較，不過最快的話還是用C或POWSER BASIC等方法，速度上會比VB快幾十上百倍的。這種每秒要檢測幾十上百倍的操作，還是要用C

uj5u.com熱心網友回復：

大神好厲害啊！！！！！！！！！

轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/81880.html

標籤：API

上一篇：VB用ADO操作資料庫字符編碼問題全部分都押上了

下一篇：求VBA 批量對比資料