Code:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Dim fs
Dim rot As Integer, grün As Integer, blau As Integer, farbealt, rotalt As Byte, grünalt As Byte, blaualt As Byte
Dim starti, startj, endi, endj, am As String, amh As String, j As Integer, jj As Long
Dim ErgebnisIR As Long, a As Picture, b As Picture, c As Picture, groesse As RECT
Dim pointert As Long, smax As Integer, xmax As Integer, ymax As Integer, xmaxalt As Integer, ymaxalt As Integer, mousex As Integer, mousey As Integer, Letztesx(10), Letztesy(10), letzter
Dim Bmp As strucBITMAP ' Struktur für die Bitmap-Rahmenangaben ' des geladenen Bildes
Dim gSafearray As strucSAFEARRAY
Dim Pic() As Integer, i As Integer, k As Integer, ii As Integer, kk As Integer
Private Declare Function VarPtrArray Lib "msvbvm60.dll" _
Alias "VarPtr" ( _
Ptr() As Any) As Long
Private Declare Function GetObject Lib "gdi32" _
Alias "GetObjectA" ( _
ByVal hObject As Long, _
ByVal nCount As Long, _
lpObject As Any) As Long
' Informationsblock der Array-Dimensionierung bei VB6
Private Type strucSAFEARRAY
Dimensionen As Integer ' Zahl der Array-Dimensionen
Features As Integer ' spezielle Array-Eigenschaften
Elemente As Long ' Angabe zum einz. Arrayfeld
Locks As Long ' Sperrvermerke
DatenZeiger As Long ' Zeiger: Speicher-Start der Arraydaten
Elements1 As Long ' Anzahl Elemente in 1.Dimension
lBound1 As Long ' Arrayuntergrenze 1. Dimension
Elements2 As Long ' s.o.
lBound2 As Long
End Type
Private Type strucBITMAP
Type As Long
PixelWidth As Long ' Bildbreite (Pixel)
PixelHeight As Long ' Bildhöhe (Pixel)
BytesWidth As Long ' Breite (in Byte; bei 24 Bit-Bitmap 3 Byte/Pixel)
Planes As Integer
BitsPerPixel As Integer ' Prog unterstützt nur 24 Bits/Pixe
BitZeiger As Long ' Zeiger auf die Bilddaten
End Type
Private Sub Command1_Click()
xmaxalt = 0: ymaxalt = 0
If Command1.Caption = "Start" Then
Command1.Caption = "Stop": Open "C:\efilm\roboter2.dat" For Append As #1: Print #1, Command1.Caption
Else
Command1.Caption = "Start": Close #1
End If
End Sub
Private Sub Form_Load()
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next 'Don't stop execution, continue on next line
' WebBrowser1.Navigate2 "http:\\www.t-online.de"
WebBrowser1.Navigate2 "http://192.168.1.20/img/main.cgi?next_file=main.htm"
If Err.Number <> 0 Then MsgBox "Error :" & Err.Description 'Display error message
Timer1.Interval = 50: Timer1.Enabled = True
Picture1.Visible = False
End Sub
Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
mousex = x: mousey = Y
End Sub
Private Sub Timer1_Timer()
Bildanalyse
End Sub
Sub Bildanalyse()
t = Timer
ErgebnisIR = FindWindow(0&, "Form1")
DoEvents: ' On Error Resume Next
Set a = CaptureWindow(ErgebnisIR, False, 5, 25, 500, 330)
SavePicture a, "C:\zwischen.bmp": Set a = LoadPicture("C:\zwischen.bmp")
If Command1.Caption = "Start" Then Set Picture2.Picture = a ' Clipboard.GetData(2) ' b
Call GetObject(a, Len(Bmp), Bmp)
With gSafearray
.Elemente = 2 'für integer
.Dimensionen = 2 ' 2-dimensionales Array
.lBound1 = 0
.Elements1 = Bmp.PixelHeight ' Bildhöhe in Pixel
.lBound2 = 0
.Elements2 = Bmp.BytesWidth / 2 ' Bildbreite in Byte !!!
.DatenZeiger = Bmp.BitZeiger ' Zeiger auf die Bilddaten
End With
' Overlay-Array für Bildzugriff
Call CopyMemory(ByVal VarPtrArray(Pic), VarPtr(gSafearray), 4)
Dim S1(600, 600) As Integer, s2(600, 600) As Integer, S3(600, 600) As Integer, S4(600, 600) As Integer, S5(600, 600) As Integer
smax = 0
On Error Resume Next
For k = 0 To UBound(Pic, 2): For i = 0 To UBound(Pic, 1)
rot = Int(Pic(i, k) / &H400): blau = Pic(i, k) And &H1F: grün = Int(Pic(i, k) / &H20) And &H1F
If mousex = i And mousey = UBound(Pic, 2) - k Then
Text1.Text = mousex & vbTab & mousey: Text3.Text = rot: Text4.Text = blau: Text5.Text = grün
End If
If rot <= blau + 2 Or rot <= grün + 2 Then
S5(i, k) = 0
Else
S5(i, k) = rot - (blau + grün) / 2
End If
Next i: Next k
For k = 0 To UBound(Pic, 2): For i = 0 To UBound(Pic, 1)
If S5(i, k) > 0 Then
S1(i, k) = S5(i, k) + (S1(i - 1, k) + S1(i, k - 1)) / 9 * 4
ii = UBound(Pic, 1) - i: kk = UBound(Pic, 2) - k:
s2(ii, kk) = S5(ii, kk) + (s2(ii + 1, kk) + s2(ii, kk + 1)) / 9 * 4
S3(i, kk) = S5(i, kk) + (S3(i - 1, kk) + S3(i, kk + 1)) / 9 * 4
S4(ii, k) = S5(ii, k) + (S4(ii + 1, k) + S4(ii, k - 1)) / 9 * 4
End If
Next i: Next k
For k = 0 To UBound(Pic, 2): For i = 0 To UBound(Pic, 1)
If S5(i, k) > 0 Then
S1(i, k) = S1(i, k) + s2(i, k) + S3(i, k) + S4(i, k)
If smax < S1(i, k) Then smax = S1(i, k): xmax = i: ymax = k
End If
Next i: Next k
ymax = UBound(Pic, 2) - ymax
Text2 = Timer - t & vbTab & xmax & vbTab & ymax: Text2.Refresh
Call CopyMemory(ByVal VarPtrArray(Pic), 0&, 4)
Picture2.FillColor = vbGreen: Picture2.FillStyle = vbFSSolid
Picture2.Circle (xmax, ymax), 1, vbGreen
letzter = letzter + 1: letzter = letzter Mod 10
Letztesx(letzter) = xmax: Letztesy(letzter) = ymax:
For i = 1 To 9: deltax = Abs(Letztesx(i) - Letztesx(0)): deltay = Abs(Letztesy(i) - Letztesy(0))
If deltax > 25 Or deltay > 25 Then i = 25:
Next
If i < 20 And xmaxalt > 0 And ymaxalt > 0 And Command1.Caption = "Stop" Then
Picture2.Line (xmax, ymax)-(xmaxalt, ymaxalt), vbGreen
Print #1, xmax, ymax
End If
If xmax > 0 And ymax > 0 Then xmaxalt = xmax: ymaxalt = ymax
End Sub
Zitieren
Lesezeichen