Keskustelu: Ohjelmointikysymykset: [VB6] etsii teksiä sovelluksen sisältä

'Moduuli
Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRGN As Long, ByVal bRedraw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Dim mousexy As POINTAPI


Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Dim SelWnd As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const flags = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
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
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 Const BI_RGB = 0&

Public Function FindColor(window As Long, colortofind As Long)
Dim WndRECT As RECT
Dim X As Long, Y As Long, test As Long
Dim nappi As Integer
Randomize
nappi = (3 * Rnd) + 1
If nappi = 1 Then
SendKeys "{left}"
Else
If nappi = 2 Then
SendKeys "{up}"
Else
If nappi = 3 Then
SendKeys "{right}"
End If
End If
End If

GetWindowRect window, WndRECT
test = GetDC(window)
For Y = 0 To (WndRECT.Bottom - WndRECT.Top)
  For X = 0 To (WndRECT.Right - WndRECT.Left)
   If GetPixel(test, X, Y) = colortofind Then
     SetCursorPos X + WndRECT.Left, Y + WndRECT.Top
     Exit Function
    End If
  Next X
Next Y
End Function

'Moduuli oon tässä yrittäny laittaa että ettii toisesta formista:
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Function FindBitmapMask(SBitmapDC As Long, posx1 As Long, posy1 As Long, posx2 As Long, posy2 As Long, MaskColor As Long) As POINTAPI
Dim X As Long, x2 As Long, Y As Long, y2 As Long, tmpPixel1 As Long, tmpPixel2 As Long, PBitmapDC As Long, mousexy As POINTAPI, FirstPixel As Long, FirstPoint As POINTAPI

PBitmapDC = Form1.hdc

For Y = 0 To Form1.Height - 1
    For X = 0 To Form1sdf.Image1.Width - 1
    tmpPixel1 = GetPixel(SBitmapDC, X, Y)
    If tmpPixel1 <> MaskColor Then
        FirstPixel = tmpPixel1
        FirstPoint.X = X
        FirstPoint.Y = Y
        GoTo Coolz0rz
    End If
    Next X
Next Y
Coolz0rz:
For Y = posy1 To posy2
    For X = posx1 To posx2
    tmpPixel1 = GetPixel(PBitmapDC, X, Y)
    If tmpPixel1 = FirstPixel Then
        For y2 = Y - FirstPoint.Y To Y + Form1sdf.Image1.Height - 1 - FirstPoint.Y
            For x2 = X - FirstPoint.X To X + Form1sdf.Image1.Width - 1 - FirstPoint.X
                tmpPixel1 = GetPixel(PBitmapDC, x2, y2)
                tmpPixel2 = GetPixel(SBitmapDC, x2 - (X - FirstPoint.X), y2 - (Y - FirstPoint.Y))
                If tmpPixel2 <> MaskColor Then
                    If tmpPixel1 <> tmpPixel2 Then GoTo NextX
                End If
                'SetPixel form1sdf.Picture2.hdc, x2, y2, 300000
            Next x2
        Next y2
        mousexy.X = X - FirstPoint.X
        mousexy.Y = Y - FirstPoint.Y
        FindBitmapMask = mousexy
        Exit Function
    End If
NextX:
    Next X
NextY:
Next Y
mousexy.X = -1
FindBitmapMask = mousexy
End Function

Public Function LoadGraphicDC(sFilename As String) As Long
On Error Resume Next
Dim LoadGraphicDCTEMP As Long, tmpObject As Long
LoadGraphicDCTEMP = CreateCompatibleDC(GetDC(0))
SelectObject LoadGraphicDCTEMP, LoadPicture(sFilename)
LoadGraphicDC = LoadGraphicDCTEMP
End Function

Dim BitmapDC As Long

Private Sub Command1_Click()
Dialog1.ShowOpen
Picture1.Picture = LoadPicture(Dialog1.FileName)
Image1.Picture = LoadPicture(Dialog1.FileName)
BitmapDC = LoadGraphicDC(Dialog1.FileName)
End Sub

Private Sub Command2_Click()
Dim mousexy As POINTAPI
Dim WndRECT As RECT
GetWindowRect Form1.hwnd, WndRECT
mousexy = FindBitmapMask(BitmapDC, 0, 0, 136, 116, Text1.Text)
If mousexy.X <> -1 Then SetCursorPos WndRECT.Left + mousexy.X + ((Picture1.Picture.Width / 2) / 20), WndRECT.Top + mousexy.Y + ((Picture1.Picture.Height / 2) / 20)

End Sub

Private Sub Form_Load()
Form1.Show
Picture1.Picture = LoadPicture(App.Path & "\rubine.bmp")
Picture2.Picture = LoadPicture(App.Path & "\bank.bmp")
Image1.Picture = Picture1.Picture
BitmapDC = Picture1.Picture
End Sub