Keskustelu: Ohjelmointikysymykset: VB6: Motion tracking

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Type pointapi
    x As Integer
    y As Integer

End Type
Private Sub Picture1_Click()

End Sub

Private Sub tref_Timer()
Static i As Integer
wb.Refresh

i = i + 1
Select Case i
    Case 1
        wb.GetImage pic
    Case 2
        wb.GetImage pic2
        DoEvents
        Diff
        i = 0
End Select

End Sub

Public Function Diff()
    Dim x As Integer
    Dim y As Integer
    Dim sCol As Long
    Dim tCol As Long
    Dim r As Integer
    Dim g As Integer
    Dim b As Integer
    Dim cnt As Long
    Dim Stepped As Integer

    Dim Mot As Integer

    Dim UL As pointapi
    Dim UR As pointapi
    Dim DL As pointapi
    Dim DR As pointapi

    UL.x = -1
    UL.y = -1

    Dim r2 As Integer
    Dim g2 As Integer
    Dim b2 As Integer
    Dim ThreS As Integer
    ThreS = 25
    mvAr.Cls
    wb.GetImage shPic
    cnt = 0
    Stepped = 3
    For x = 1 To pic.Width Step Stepped
        For y = 1 To pic.Height Step Stepped
            sCol = GetPixel(pic.hdc, x, y)
            tCol = GetPixel(pic2.hdc, x, y)
            ColorCodeToRGB sCol, r, g, b
            ColorCodeToRGB tCol, r2, g2, b2
            If r2 > r - ThreS And r2 < r + ThreS Then
            Else
                    If UL.x = -1 And UL.y = -1 Then
                        UL.x = x
                        UL.y = y
                    End If
                    'shPic.PSet (x, y), RGB(255, 0, 0)
                    mvAr.PSet (x, y), sCol
                    cnt = cnt + 1
                    DR.x = x
                    DR.y = y
            End If
            If g2 > g - ThreS And g2 < g + ThreS Then
            Else
                    If UL.x = -1 And UL.y = -1 Then
                        UL.x = x
                        UL.y = y
                    End If
                    'shPic.PSet (x, y), RGB(0, 255, 0)
                    mvAr.PSet (x, y), sCol
                    cnt = cnt + 1
                    DR.x = x
                    DR.y = y
            End If
            If b2 > b - ThreS And b2 < b + ThreS Then
            Else
                    If UL.x = -1 And UL.y = -1 Then
                        UL.x = x
                        UL.y = y
                    End If
                    'shPic.PSet (x, y), RGB(0, 0, 255)
                    mvAr.PSet (x, y), sCol
                    cnt = cnt + 1
                    DR.x = x
                    DR.y = y
            End If
            DoEvents
        Next y
        DoEvents
    Next x
    DL.x = UL.x
    DL.y = DR.y
    UR.x = DR.x
    UR.y = UL.y
        Mot = Int((((cnt / 3) / ((pic.Height / Stepped) * (pic.Width / Stepped))) * 100))

    If Mot >= 5 Then
        shPic.Line (UL.x, UL.y)-(DL.x, DL.y), RGB(25, 25, 255)
        shPic.Line (UR.x, UR.y)-(DR.x, DR.y), RGB(25, 25, 255)
        shPic.Line (UL.x, UL.y)-(UR.x, UR.y), RGB(25, 25, 255)
        shPic.Line (DL.x, DL.y)-(DR.x, DR.y), RGB(25, 25, 255)


    End If
    Me.Caption = "Motion " & Mot & "%"
End Function


Public Function ColorCodeToRGB(lColorCode As Long, iRed As Integer, iGreen As Integer, iBlue As Integer) As Boolean
    Dim lColor As Long
    lColor = lColorCode
    iRed = lColor Mod &H100
    lColor = lColor \ &H100
    iGreen = lColor Mod &H100
    lColor = lColor \ &H100
    iBlue = lColor Mod &H100
    ColorCodeToRGB = True
End Function