Keskustelu: Ohjelmointikysymykset: [VB6] Nopein tapa selvittää pikselin väri

Option Explicit
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 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 Const DIB_RGB_COLORS = 0&
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Sub Command1_Click()
Dim ScreenDC As Long, CompDC As Long, CompBMP As Long, ScreenWidth As Long, ScreenHeight As Long
Dim ScreenBits() As Long, Offset As Long, MaxOffset As Long, BMPInfo As BITMAPINFO, StartTime As Long
StartTime = timeGetTime()                                                          'Alotusaika millisekunteina windowsin käynnistyksestä
ScreenWidth = Screen.Width / Screen.TwipsPerPixelX                                 'Ruudun leveys
ScreenHeight = Screen.Height / Screen.TwipsPerPixelY                               'Ruudun korkeus
ScreenDC = GetDC(0)                                                                'Ruudun piirtokahva
CompDC = CreateCompatibleDC(ScreenDC)                                              'Väliaikainen piirtokahva ruudusta
CompBMP = CreateCompatibleBitmap(ScreenDC, ScreenWidth, ScreenHeight)              'Väliaikainen bitmappi ruudusta
SelectObject CompDC, CompBMP                                                       'Yhdistetään luotu bitmappi ja kahva
With BMPInfo.bmiHeader                                                             'Asetetaan kaapattavan kuvan tiedot
    .biSize = 40                                                                   'Rakenteen koko (aina 40)
    .biWidth = ScreenWidth                                                         'Kuvan leveys
    .biHeight = -ScreenHeight                                                      'Kuvan korkeus
    .biPlanes = 1                                                                  '?, aina 1
    .biBitCount = 32                                                               'Värisyvyys
    .biCompression = 0                                                             'Pakkaus (ei mitään)
End With
MaxOffset = ScreenWidth * ScreenHeight                                             'Taulukkoon vaadittavien pikselien määrä
ReDim ScreenBits(0 To MaxOffset)
BitBlt CompDC, 0, 0, ScreenWidth, ScreenHeight, ScreenDC, 0, 0, vbSrcCopy          'Blitataan ruutu väliaikaiseen piirtokahvaan
GetDIBits CompDC, CompBMP, 0, ScreenHeight, ScreenBits(0), BMPInfo, DIB_RGB_COLORS 'Kaapataan väliaik. piirtokahvan pikselit RGB-muodossa
For Offset = 0 To MaxOffset
    If ScreenBits(Offset) = Text1.Text Then                                        'Loopataan yksiulotteista taulukkoa
        Dim x As Long, y As Long                                                   'Värit muodossa R * 65536 + G * 256 + B
        x = Offset Mod ScreenWidth                                                 'Väri löydetty, kohdan leveys
        y = Offset / ScreenWidth                                                   'Kohdan korkeus
        SetCursorPos x, y                                                          'Kurso sen kohalle
        MsgBox "Color found at " & x & "." & y & " in " & timeGetTime() - StartTime & " ms.", vbInformation, "Color found!"
        Exit For                                                                   'Ilmotettii värin löydöstä
    End If
Next Offset
DeleteDC ScreenDC                                                                  'Poistetaa käytetyt kahvat
DeleteDC CompDC
End Sub