Code aus Form1.frm
Option Explicit
Private Sub Command1_Click()
  Dim histogram(359) As Long, x As Long, y As Long, r As Long
  Dim max As Long, factor As Double, curr As Long, g As Long, b As Long
  Dim color As Long, i As Long, n As Long
  Dim h As Long, s As Long, v As Long, mid_s As Double, mid_v As Double
    
  Dim x1 As Long, x2 As Long, y1 As Long, y2 As Long, cnt As Currency
    
    Picture1.Picture = LoadPicture(App.Path & "\weights.bmp")
    
    x1 = 200: y1 = 110
    x2 = 320: y2 = 220
    
    n = Slider1.value
    
    For y = y1 To y2
      For x = x1 To x2
        color = Picture1.Point(x, y)
        b = color And &HFF
        g = (color \ 2 ^ 8) And &HFF
        r = (color \ 2 ^ 16) And &HFF
        
        RGBtoHSV r, g, b, h, s, v
        Debug.Assert h <= 359
        Debug.Assert h >= 0
        
        mid_s = mid_s + s
        mid_v = mid_v + v
        cnt = cnt + 1
        
        h = (h \ n) * n
        For i = 0 To n - 1
          If h + i < 360 Then
            histogram(h + i) = histogram(h + i) + 1
          End If
        Next i
      Next x
    Next y
    
    mid_s = mid_s / cnt
    mid_v = mid_v / cnt
    
    Debug.Print "Mid S/V:", mid_s, mid_v
    
    Debug.Print "Erstellt"
    
    For x = 0 To 359
      If histogram(x) > max Then
        max = histogram(x)
      End If
    Next x
    
    Debug.Print "Max:", max
    
    factor = 200 / max
    
    Debug.Print "Factor:", factor
    
    Picture2.Cls
    
    x = 1
    For y = 0 To 359
      curr = histogram(y) * factor
      Picture2.Line (x, Picture2.ScaleHeight - 1)-(x + 1, _
          Picture2.ScaleHeight - curr - 1), RGB(255, 0, 0), BF
      
      x = x + 2
    Next y
    
    Debug.Print "Gezeichnet"
    
    'Backproject Calculation
    factor = 255 / max
    
  Dim diff1 As Double, diff2 As Double
    
    Picture3.Cls
    
    For y = 0 To Picture1.ScaleHeight
      For x = 0 To Picture1.ScaleWidth
        color = Picture1.Point(x, y)
        b = color And &HFF
        g = (color \ 2 ^ 8) And &HFF
        r = (color \ 2 ^ 16) And &HFF
        
        RGBtoHSV r, g, b, h, s, v
        Debug.Assert h <= 359
        Debug.Assert h >= 0
        
        diff1 = Abs(Slider3.value - s) / 100
        diff2 = Abs(Slider4.value - v) / 100
        
        color = histogram(h) * factor * Slider2.value * (1 - _
            diff1) * (1 - diff2)
        Picture3.PSet (x, y), RGB(color, color, color)
      Next x
    Next y
    
    Picture1.Line (x1, y1)-(x2, y2), RGB(255, 0, 0), B
End Sub
Private Sub Form_Load()
    Picture1.Picture = LoadPicture(App.Path & "\weights.bmp")
    Picture3.Picture = LoadPicture(App.Path & "\weights.bmp")
End Sub
Sub RGBtoHSV(r_1 As Long, g_1 As Long, b_1 As Long, hue As Long, _
    sat As Long, value As Long)
  Dim min As Double, max As Double, delta As Double
  Dim r As Double, g As Double, b As Double
  Dim h As Double, s As Double, v As Double
    
    r = r_1 / 255
    g = g_1 / 255
    b = b_1 / 255
    
    min = 1
    If min > r Then
      min = r
    End If
    If min > g Then
      min = g
    End If
    If min > b Then
      min = b
    End If
    
    If max < r Then
      max = r
    End If
    If max < g Then
      max = g
    End If
    If max < b Then
      max = b
    End If
    
    v = max
    delta = max - min
    
    If delta = 0 Then
      h = 0
      s = 0
      Exit Sub
    End If
    
    If max <> 0 Then
      s = delta / max
    Else
      s = 0
      h = -1
      Exit Sub
    End If
    
    If r = max Then
      h = (g - b) / delta
    ElseIf g = max Then
      h = 2 + (b - r) / delta
    Else
      h = 4 + (r - g) / delta
    End If
    
    h = h * 60
    
    If h < 0 Then
      h = h + 360
    End If
    
    hue = h
    sat = s * 100
    value = v * 100
End Sub
Private Sub Slider1_Change()
    Call Command1_Click
End Sub
Private Sub Slider2_Change()
    Call Command1_Click
End Sub