none
vb.net 用GetDIBits获取屏幕颜色 5000次后失效 RRS feed

  • 问题

  • 先贴代码:

    Imports System.Runtime.InteropServices
    Public Class form1
        Public Structure PointAPI
            Dim x As Integer
            Dim y As Integer
        End Structure
        Public Function ConvertString(
            ByVal value As String,
            ByVal fromBase As Integer,
            ByVal toBase As Integer) As String
            Dim n As Integer = Convert.ToInt32(value, fromBase)
            Return Convert.ToString(n, toBase)
        End Function

        Public P As PointAPI

        Public Declare Auto Function FindWindow Lib "user32.dll" _
            Alias "FindWindow" (ByVal lpClassName As String,
                                ByVal lpWindowName As String) As Integer
        Declare Ansi Function GetCursorPos Lib "user32" (ByRef lpPoint As PointAPI) As Integer
        Public Declare Function WindowFromPoint Lib "user32" (x As Integer, y As Integer) As Integer
        'Public Declare Auto Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Integer) As Integer
        Public Declare Function ScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hwnd As Integer, ByRef lpPoint As PointAPI) As Integer
        Declare Function GetPixel Lib "gdi32" Alias "GetPixel" (ByVal hdc As Integer, ByVal x As Integer, ByVal y As Integer) As Integer
        Public Declare Function ReleaseDC Lib "user32" (hWnd As Integer, hDC As Integer) As Integer
        Public Declare Auto Function DeleteDC Lib "gdi32.dll" (ByRef hdc As IntPtr) As Boolean
        Public Declare Auto Function DeleteObject Lib "gdi32.dll" (ByRef hobject As IntPtr) As Boolean

        'Public Declare Function timeGetTime Lib "winmm.dll" () As Integer
        Public Declare Function GetPhysicalCursorPos Lib "user32" (ByRef lpPoint As PointAPI) As Integer
        Public Declare Function SetPhysicalCursorPos Lib "user32" (ByVal x As Integer, ByVal y As Integer) As Integer
        Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As System.Text.StringBuilder) As Integer
        Public lparam As New System.Text.StringBuilder
        Const WM_GETTEXT = &HD
        Const WM_KEYDOWN = &H100
        Const WM_KEYUP = &H101
        Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Integer, ByVal lpString As String, ByVal cch As Integer) As Integer
        Public Declare Function SetCursorPos Lib "user32" (ByVal x As Integer, ByVal y As Integer) As Integer


        Public Declare Function timeGetTime Lib "winmm.dll" () As Integer
        Public Declare Function GetDC Lib "user32" Alias "GetDC" (ByVal hwnd As Integer) As Integer
        Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As String) As Integer
        Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Integer) As Integer
        Private Declare Function GetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Integer, ByVal nIndex As Integer) As Integer
        Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
        Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
        Private Declare Function BitBlt Lib "GDI32" (ByVal deshDC As Integer, ByVal desX As Integer, ByVal desY As Integer, ByVal desW As Integer, ByVal desH As Integer, ByVal srchDC As Integer, ByVal srcX As Integer, ByVal srcY As Integer, ByVal op As Integer) As Integer
        Const SRCCOPY = &HCC0020    ' (DWORD) dest = source
        Const SRCINVERT = &H660046  ' (DWORD) dest = source XOR dest
        Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal nSrcWidth As Integer, ByVal nSrcHeight As Integer, ByVal dwRop As Integer) As Integer
        Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Integer, ByVal hBitmap As Integer, ByVal nStartScan As Integer, ByVal nNumScans As Integer, ByVal lpBits As Integer, ByRef lpBI As BITMAPINFO, ByVal wUsage As Integer) As Integer
        Private Declare Function CreateDIBSection Lib "GDI32" (ByVal hdc As Integer, ByRef pbmi As BITMAPINFO, ByVal iUsage As Integer, ByRef ppvBits As Integer, ByVal hSection As Integer, ByVal dwOffset As Integer) As Integer
        Private Declare Function SetDIBits Lib "GDI32.dll" (ByVal hDC As Integer, ByVal hBitmap As Integer, ByVal nStartScan As Integer, ByVal nNumScans As Integer, ByRef lpBits As Integer, ByRef lpBI As BITMAPINFO, ByVal wUsage As Integer) As Integer
        Public Structure RGBTRIPLE
            Public rgbBlue As Byte
            Public rgbGreen As Byte
            Public rgbRed As Byte
        End Structure
        Public Structure BITMAPINFOHEADER
            Public biSize As Integer
            Public biWidth As Integer
            Public biHeight As Integer
            Public biPlanes As Short
            Public biBitCount As Short
            Public biCompression As Integer
            Public biSizeImage As Integer
            Public biXPelsPerMeter As Integer
            Public biYPelsPerMeter As Integer
            Public biClrUsed As Integer
            Public biClrImportant As Integer
        End Structure
        Public Structure BITMAPINFO
            Public bmiHeader As BITMAPINFOHEADER
            Public bmColors() As RGBTRIPLE
        End Structure
        Public Const DIB_RGB_COLORS As Integer = 0

        Public Structure BitBlt_RECT
            Dim x1 As Integer
            Dim y1 As Integer
            Dim x2 As Integer
            Dim y2 As Integer
        End Structure
        Public BR As New BitBlt_RECT

        Public CR, CB, CG As Integer

        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
            Dim going_on As Boolean = True

            Me.SetDesktopLocation(968, 30)
            Show()

            Dim t As Integer
            t = 0
            Do While going_on
                t += 1

                With BR
                    .x1 = P.x
                    .y1 = P.y
                    .x2 = P.x + 1
                    .y2 = P.y + 1
                End With

                GetDIBits_maping()

                GetPhysicalCursorPos(P)
                TextBox12.Text = " x =" + Str(P.x)
                TextBox13.Text = " y =" + Str(P.y)

                TextBox3.Text = "R =" + Str(CR)
                TextBox4.Text = "G =" + Str(CG)
                TextBox5.Text = "B =" + Str(CB)

                TextBox8.Text = TextBox8.Text + ",t=" + Trim(Str(t))
                Application.DoEvents()
            Loop

        End Sub

        Private Sub GetDIBits_maping()
            Dim hdc, hdcMem, hbmp, hBmpPrev, NewBMP2 As Integer
            Dim start_coo_x, start_coo_y, W, H As Integer
            Dim textureImg(10) As Byte

            start_coo_x = BR.x1 : start_coo_y = BR.y1
            W = BR.x2 - BR.x1 : H = BR.y2 - BR.y1

            Dim bi24BitInfo As New BITMAPINFO
            With bi24BitInfo.bmiHeader
                .biSize = 40 'System.Runtime.InteropServices.Marshal.SizeOf(GetType(BITMAPINFO))
                .biBitCount = 24
                .biCompression = 0 ' BI_RGB
                .biPlanes = 1
                .biWidth = W
                .biHeight = H
                .biXPelsPerMeter = 0
                .biYPelsPerMeter = 0
                .biSizeImage = W * H * 3
                .biClrUsed = 0
                .biClrImportant = 0
            End With

            Dim r As Integer

            hdc = GetDC(0)
            TextBox7.Text = "hdc(0) =" + Str(hdc)

            hdcMem = CreateCompatibleDC(hdc)
            hbmp = CreateCompatibleBitmap(hdc, W, H)
            hBmpPrev = SelectObject(hdcMem, hbmp)

            r = BitBlt(hdcMem, 0, 0, W, H, hdc, start_coo_x, start_coo_y, &HCC0020)
            TextBox8.Text = " R=" + Trim(Str(r))

            NewBMP2 = SelectObject(hdcMem, hBmpPrev)

            Dim gch As GCHandle
            gch = GCHandle.Alloc(textureImg, GCHandleType.Pinned)
            r = GetDIBits(hdc, NewBMP2, 0, H, gch.AddrOfPinnedObject, bi24BitInfo, 0)

            CB = textureImg(0)
            CG = textureImg(1)
            CR = textureImg(2)

            gch.Free()
            DeleteObject(hbmp)
            DeleteDC(hdcMem)

            DeleteObject(hBmpPrev)  '不知道是否有必要delete,有没有这句话没差别
            DeleteObject(NewBMP2)  '不知道是否有必要delete,有没有这句话没差别
            DeleteDC(r)                    '不知道是否有必要delete,有没有这句话没差别


            ReleaseDC(0, hdc)
            GC.Collect()

        End Sub


        Private Sub form1_Disposed(sender As Object, e As EventArgs) Handles Me.Disposed
            End
        End Sub
    End Class

    该程序运行5000次左右没问题.超过5000次,hdc = GetDC(0)就很少能取到了,取到的颜色也都是零了.

    运行中,占用的内存一直在增加,开始运行到运行5000次大约能增加20MB.不清楚是否有内存泄露.

    我的运行环境: I7 4790,内存12G,没有独立显卡,64位win10 最新版本, DELL商务机

    本人姓菜名鸟,请前辈帮忙看看我的问题出在哪里!   非常感谢!!!

    2016年7月31日 11:36

全部回复