VB6 Neopets OCR

This is the fastest writable and most accurate Neopets OCR I've written.

Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Dim SA As SAFEARRAY2D, Data() As Byte

Private Sub picArr(captcha As StdPicture)
Dim BMP As BITMAP
    GetObjectAPI captcha.Handle, Len(BMP), BMP
    SA.cbElements = 1: SA.cDims = 2
    SA.Bounds(0).cElements = BMP.bmHeight
    SA.Bounds(1).cElements = BMP.bmWidth * 3 + 3 And &HFFFFFFFC
    SA.pvData = BMP.bmBits
    CopyMemory ByVal VarPtrArray(Data), VarPtr(SA), 4
End Sub

Private Sub dBox(ByVal x1&, ByVal y1&, ByVal R&)
Dim i As Integer
    For i = 0 To R
        Data((x1 + i) * 3 + 1, y1 + R) = 1 And &HFF
        Data((x1 + i) * 3 + 1, y1 - R) = 1 And &HFF
        Data((x1 - i) * 3 + 1, y1 + R) = 1 And &HFF
        Data((x1 - i) * 3 + 1, y1 - R) = 1 And &HFF
        Data((x1 + R) * 3 + 1, y1 + i) = 1 And &HFF
        Data((x1 + R) * 3 + 1, y1 - i) = 1 And &HFF
        Data((x1 - R) * 3 + 1, y1 + i) = 1 And &HFF
        Data((x1 - R) * 3 + 1, y1 - i) = 1 And &HFF
    Next i
End Sub

Public Function ChangePicture(picNewCaptcha As String)
    picCaptcha.Picture = LoadPicture(picNewCaptcha)
End Function

Public Function OCR() As String
Dim xPl As Long, yPl As Long, curCol As Long, i As Long
Dim t As Long: t = timeGetTime()
    picArr picCaptcha.Picture
    For xPl = 20 To picCaptcha.ScaleWidth - 20 Step 2
        For yPl = 20 To picCaptcha.ScaleHeight - 20 Step 2
            curCol = ((Data(xPl * 3, yPl) * 256&) + Data(xPl * 3 + 1, yPl)) * 256& + Data(xPl * 3 + 2, yPl)
            If (curCol And &HFF) + ((curCol \ 256) And &HFF) + ((curCol \ 65536) And &HFF) < 230 Then
                dBox xPl, yPl, 4
                yPl = picCaptcha.ScaleHeight - yPl
                OCR = "&x=" & xPl & "&y=" & yPl
                t = timeGetTime() - t
                picCaptcha.Refresh
                Exit Function
            End If
        Next yPl
    Next xPl
End Function

Copy that code into a 'User Control'; on the user control, you will need a PictureBox named picCaptcha. Under Properties of picCaptcha, ensure that ScaleMode has been set to '3 - Pixel'. Add this user control to your form and name it sockOCR, or, change it to whatever you want, in the following examples, the user control will be named sockOCR.

Change the picture on the user control:

sockOCR.ChangePicture App.Path & "\captcha.jpg"

Retrieve the co-ordinates from the image:

strCoordinates = sockOCR.OCR

and the new value of strCoordinates would be exactly that, the co-ordinates, which may be something like "&x=50&y=20"



This OCR more times than not takes less than 0 milliseconds to fully execute and return the co-ordinates, and was accurate on 9172 out of the 9173 tested images. Inserting the whole function into a Do loop that executes with a very dark color difference and decreases the acceptable color difference value until a dark enough spot is found increases the accuracy to 100% but sacrifices up to a couple milliseconds of time.