Code aus Form1.frm
Option Explicit
Const Pi = 3.14159265358979
Private Sub Command1_Click()
  Dim curx As Currency, cury As Currency, hx As Currency, hy As Currency
  Dim startx As Currency, starty As Currency, starthx As Currency, _
      starthy As Currency
  Dim incx As Double, incy As Double, dist2 As Double, eps2 As Double
    
  Dim a_m00() As Currency
  Dim m00 As Currency, m01 As Currency, m10 As Currency, m02 As _
      Currency, m20 As Currency
  Dim m11 As Currency
    
  Dim a As Double, b As Double, c As Double, alpha As Double, w As _
      Double
  Dim l As Double, s As Double
    
  Dim i As Currency, lastdist As Double
    
    starthx = Picture1.ScaleWidth \ 2 - 10: starthy = _
        Picture1.ScaleHeight \ 2 - 10
    startx = Picture1.ScaleWidth \ 2: starty = Picture1.ScaleHeight \ 2
    
    hx = starthx: hy = starthy
    curx = startx: cury = starty
    
    eps2 = 0.000000001
    dist2 = 2
    
    While (dist2 > eps2 And i < 1000) And lastdist <> dist2
      i = i + 1
      
      Debug.Print "Durchlauf", i
      
      lastdist = dist2
      
      ReadSubwin a_m00, curx, cury, hx, hy
      
      CalculateMoments a_m00, hx, hy, m00, m10, m01, m11, m20, m02
      
      ' m00 I
      ' m10 x I
      ' m01 y I
      ' m11 xy I
      ' m20 x^2 I
      ' m02 y^2 I
      
      'Normal Meanshift
      If m00 <> 0 Then
        incx = m10 / m00
        incy = m01 / m00
      Else
        'Leeres Suchfenster
        incx = 20
        incy = 20
      End If
      
      Debug.Print "Verschiebung:", incx, incy
      
      curx = Round(curx + incx)
      cury = Round(cury + incy)
      
      dist2 = incx ^ 2 + incy ^ 2
      
      Debug.Print "Distanz:", dist2
      
      a = m20 / m00
      b = m11 / m00
      c = m02 / m00
      
      alpha = 0.5 * Atann(b, a - c)
      w = Sqr(0.5 * (a + c - Sqr(b ^ 2 + (a - c) ^ 2))) * 2
      l = Sqr(0.5 * (a + c + Sqr(b ^ 2 + (a - c) ^ 2))) * 2
      
      s = Sqr(m00 / 256)
      
      hx = Round(s)
      hy = Round(s)
      
      Debug.Print "Neues Fenster:", w, l, alpha
    Wend
    
    Picture1.Line (curx - hx, cury - hy)-(curx + hx, cury + hy), , B
    Picture1.Line (startx - starthx, starty - starthy)-(startx + _
        starthx, starty + starthy), RGB(0, 0, 150), B
    
  Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
    
    x1 = curx + Sin(alpha) * l
    y1 = cury + Cos(alpha) * l
    
    x2 = curx - Sin(alpha) * l
    y2 = cury - Cos(alpha) * l
    
    Picture1.Line (x1, y1)-(x2, y2), RGB(255, 0, 0)
    
    x1 = curx - Cos(alpha) * w
    y1 = cury + Sin(alpha) * w
    
    x2 = curx + Cos(alpha) * w
    y2 = cury - Sin(alpha) * w
    
    Picture1.Line (x1, y1)-(x2, y2), RGB(255, 0, 0)
End Sub
Sub CalculateMoments(a_m00() As Currency, ByVal hx As Currency, _
    ByVal hy As Currency, m00 As Currency, m10 As Currency, m01 As _
    Currency, m11 As Currency, m20 As Currency, m02 As Currency)
  Dim xarr() As Currency, yarr() As Currency, a_m10() As Currency, _
      a_m01() As Currency
  Dim a_m11() As Currency, a_m20() As Currency, a_m02() As _
      Currency, x As Currency, y As Currency
    
    ReDim xarr(2 * hx, 2 * hy)
    ReDim yarr(2 * hx, 2 * hy)
    
    m00 = SumXY(a_m00)
    
    ReDim a_m10(2 * hx, 2 * hy)
    ReDim a_m01(2 * hx, 2 * hy)
    
    For y = 0 To 2 * hy
      For x = -hx To hx
        xarr(x + hx, y) = x
      Next x
    Next y
    
    For x = 0 To 2 * hx
      For y = -hy To hy
        yarr(x, y + hy) = y
      Next y
    Next x
    
    MultArray a_m00, xarr, a_m10
    MultArray a_m00, yarr, a_m01
    
    m10 = SumXY(a_m10)
    m01 = SumXY(a_m01)
    
    For y = 0 To 2 * hy
      For x = -hx To hx
        xarr(x + hx, y) = x ^ 2
      Next x
    Next y
    
    For x = 0 To 2 * hx
      For y = -hy To hy
        yarr(x, y + hy) = y ^ 2
      Next y
    Next x
    
    MultArray a_m00, xarr, a_m20
    MultArray a_m00, yarr, a_m02
    
    m20 = SumXY(a_m20)
    m02 = SumXY(a_m02)
    
    For x = -hx To hx
      For y = -hy To hy
        xarr(x + hx, y + hy) = x * y
      Next y
    Next x
    
    MultArray a_m00, xarr, a_m11
    
    m11 = SumXY(a_m11)
End Sub
Private Sub Form_Load()
    Picture1.Picture = LoadPicture(App.Path & "\weights.bmp")
End Sub
Function SumXY(arr() As Currency) As Currency
  Dim x As Currency, y As Currency, sum As Currency
    
    For y = LBound(arr, 1) To UBound(arr, 2)
      For x = LBound(arr, 2) To UBound(arr, 1)
        sum = sum + arr(x, y)
      Next x
    Next y
    
    SumXY = sum
End Function
Sub ReadSubwin(ByRef subwin() As Currency, curx As Currency, cury _
    As Currency, hx As Currency, hy As Currency)
  Dim x As Currency, y As Currency
    
    ReDim subwin(2 * hx, 2 * hy)
    For x = curx - hx To curx + hx
      For y = cury - hy To cury + hy
        subwin(x - curx + hx, y - cury + hy) = 255 - _
            (Picture1.Point(x, y) And &HFF)
      Next y
    Next x
End Sub
Sub MultArray(inp() As Currency, mult() As Currency, out() As Currency)
  Dim x As Currency, y As Currency
    
    ReDim out(UBound(inp, 1), UBound(inp, 2))
    
    For x = LBound(inp, 1) To UBound(inp, 1)
      For y = LBound(inp, 2) To UBound(inp, 2)
        out(x, y) = inp(x, y) * mult(x, y)
      Next y
    Next x
End Sub
'Die Funktion Atann stammt von ActiveVB. Sie erweitert die VB-eigene
'Funktion atn, welche nicht alle Quadranten beachtet
Function Atann(x, y)
  Dim alpha As Double
  Dim atan As Double
    
    If x <> 0 Then
      atan = Atn(Abs(y) / Abs(x))
    Else
      atan = 0
    End If
    
    Select Case x
      Case Is > 0
        If y >= 0 Then
          alpha = atan
        Else
          alpha = 2 * Pi - atan
        End If
      Case Is < 0
        If y >= 0 Then
          alpha = Pi - atan
        Else
          alpha = atan + Pi
        End If
      Case Is = 0
        Select Case y
          Case Is > 0
            alpha = Pi / 2
          Case Is < 0
            alpha = 3 * Pi / 2
          Case Is = 0
            alpha = 0
        End Select
    End Select
    
aus_atann:
    Atann = alpha
End Function