classimageprocessing.cls

优秀的面部识别程序,用VB开发的

            yy = sy + 1
            direction = 135
          End If
        End If
      End If
    
    End If
    
    If (sy < height - 1) Then
      value = image(sx, sy + 1)
      If ((value > thresh) And (temp(sx, sy + 1) = False)) Then
        If (value > max) And ((averagedirection > 90) And (averagedirection < 270)) Then
          max = value
          xx = sx
          yy = sy + 1
          direction = 180
        End If
      End If
    End If
    
    If (sx > 0) Then
      
      If (sy < height - 1) Then
        value = image(sx - 1, sy + 1)
        If ((value > thresh) And (temp(sx - 1, sy + 1) = False)) Then
          If (value > max) And ((averagedirection > 135) And (averagedirection < 315)) Then
            max = value
            xx = sx - 1
            yy = sy + 1
            direction = 225
          End If
        End If
      End If
      
      value = image(sx - 1, sy)
      If ((value > thresh) And (temp(sx - 1, sy) = False)) Then
        If (value > max) And ((averagedirection > 180) Or (averagedirection = 0)) Then
          max = value
          xx = sx - 1
          yy = sy
          direction = 270
        End If
      End If
      
      If (sy > 0) Then
        value = image(sx - 1, sy - 1)
        If ((value > thresh) And (temp(sx - 1, sy - 1) = False)) Then
          If (value > max) And ((averagedirection > 225) Or (averagedirection < 45)) Then
            max = value
            xx = sx - 1
            yy = sy - 1
            direction = 315
          End If
        End If
      End If
    End If
    
    If (averagedirection > 0) Then
      intensity = (intensity + max) / 2
      directionDifference = Abs(averagedirection - direction)
      If (directionDifference > 180) Then
        directionDifference = 360 - directionDifference
      End If
      averagedirection = averagedirection - (directionDifference / 2)
      If (averagedirection < 0) Then
        averagedirection = 360 + averagedirection
      End If
      If (averagedirection > 360) Then
        averagedirection = averagedirection - 360
      End If
      
      If ((edgeLength > 3) And (directionDifference > 20) And (traceEdgesFromPoint)) Then
        Call addEdgeVector(initialX, initialY, xx, yy, intensity)
        initialX = xx
        initialY = yy
      End If
      
      Else
      intensity = max
      averagedirection = direction
    End If
  
  Wend
  
  If (traceEdgesFromPoint = True) Then
    Call addEdgeVector(initialX, initialY, xx, yy, intensity)
  End If
  
  If (initialEdgeLength = 0) Then
    'If (edgeLength > minEdgeLength) Then
      For i = 0 To width - 1
        For j = 0 To height - 1
          If (temp(i, j) = True) Then
            edgeTraced(i, j) = True
          End If
        Next
      Next
    'End If
  End If
  
  x = xx
  y = yy
  traceDirection = direction
  
End Function


Private Sub addEdgeVector(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, intensity As Single)
'adds a new edge vector

  If (currEdgeVector < EDGE_VECTOR_LENGTH) Then
    EdgeVector(0, currEdgeVector) = x1
    EdgeVector(1, currEdgeVector) = y1
    EdgeVector(2, currEdgeVector) = x2
    EdgeVector(3, currEdgeVector) = y2
    EdgeVector(4, currEdgeVector) = intensity
    If (intensity > maxEdgeVectorIntensity) Then
      maxEdgeVectorIntensity = intensity
    End If
    currEdgeVector = currEdgeVector + 1
  End If
End Sub


Private Sub sortEdgeVector()
'sorts the edge vector by distance
  
  Dim dx As Integer
  Dim dy As Integer
  Dim length As Long
  Dim mindist As Long
  Dim closest As Integer
  Dim vect As Single
  Dim i As Integer
  Dim j As Integer

  For i = 0 To currEdgeVector - 2
    mindist = 99999
    closest = 0
    For j = i + 1 To currEdgeVector - 1
      dx = EdgeVector(2, i) - EdgeVector(0, j)
      dy = EdgeVector(3, i) - EdgeVector(1, j)
      length = (dx * dx) + (dy * dy)
      If (length < mindist) Then
        mindist = length
        closest = j
      End If
    Next
    If ((closest > 0) And (closest <> i + 1)) Then
      'swap
      For j = 0 To 4
        vect = EdgeVector(j, i + 1)
        EdgeVector(j, i + 1) = EdgeVector(j, closest)
        EdgeVector(j, closest) = vect
      Next
    End If
  Next
  
  
    
  'For i = 0 To currEdgeVector - 1
  '  For j = 0 To currEdgeVector - 1
  '    If (i <> j) Then
  '      dx = EdgeVector(0, i) - EdgeVector(0, j)
  '      dy = EdgeVector(1, i) - EdgeVector(1, j)
  '      length = ((dx * dx) + (dy * dy))
  '      If (length < 3 * 3) Then
  '        EdgeVector(0, i) = EdgeVector(0, i) - (dx / 2)
  '        EdgeVector(1, i) = EdgeVector(1, i) - (dy / 2)
  '        EdgeVector(0, j) = EdgeVector(0, j) + (dx / 2)
  '        EdgeVector(1, j) = EdgeVector(1, j) + (dy / 2)
  '      End If
  '      dx = EdgeVector(2, i) - EdgeVector(2, j)
  '      dy = EdgeVector(3, i) - EdgeVector(3, j)
  '      length = ((dx * dx) + (dy * dy))
  '      If (length < 3 * 3) Then
  '        EdgeVector(2, i) = EdgeVector(2, i) - (dx / 2)
  '        EdgeVector(3, i) = EdgeVector(3, i) - (dy / 2)
  '        EdgeVector(2, j) = EdgeVector(2, j) + (dx / 2)
  '        EdgeVector(3, j) = EdgeVector(3, j) + (dy / 2)
  '      End If
  '    End If
  '  Next
  'Next
  
End Sub


Private Function dist(x1 As Single, y1 As Single, x2 As Single, y2 As Single) As Single
  Dim dx As Single
  Dim dy As Single
  
  dx = x1 = x2
  dy = y1 - y2
  dist = Sqr((dx * dx) + (dy * dy))
End Function



Public Sub getEdges()
'updates the edges

  Dim mask
  Dim i As Integer
  Dim j As Integer
  Dim x As Integer
  Dim y As Integer
  Dim xx As Integer
  Dim yy As Integer
  Dim diff As Long
  Dim thresh As Integer
  Dim diff2 As Long
  Dim estr As String
  Dim minDiff As Long
  Dim winner As Integer
  Dim ex As Integer
  Dim ey As Integer
  Dim av As Integer
  
  thresh = 100
  
  For i = 0 To NO_OF_EDGE_TYPES - 1
    EdgeHistogram(i) = 0
  Next
  
  x = 0
  ex = 0
  While (x < width - 2)
    y = 0
    ey = 0
    While (y < height - 2)
      Edges(ex, ey) = 0
      minDiff = 9999999
      winner = -1
      For i = 0 To NO_OF_EDGE_MASKS - 1
        mask = EdgeMask(i)
        diff = 0
        j = 0
        av = 0
        For yy = y To y + 2
          For xx = x To x + 2
            av = av + image(xx, yy)
            diff2 = Abs((mask(j) * 255) - image(xx, yy))
            diff = diff + diff2
            j = j + 1
          Next
        Next
        If (av / 9 > 30) Then
        
          'edge
          
          diff = diff / 9
          If (diff < minDiff) And (diff < thresh) Then
            winner = mask(9)
            minDiff = diff
            Edges(ex, ey) = winner
          End If
          
          Else
          
          'blank
          winner = 0
          Edges(ex, ey) = winner
          
        End If
      Next
      'Edges(ex, ey) = Rnd * 5  'test
      If (winner > 0) Then
        EdgeHistogram(winner - 1) = EdgeHistogram(winner - 1) + 1
      End If
      ey = ey + 1
      y = y + 2
    Wend
    ex = ex + 1
    x = x + 2
  Wend
  
  'fill in the gaps
  Call getEdges_secondary

End Sub


Public Sub getEdges_secondary()
'fills in edges where they "should" appear
  Dim x As Integer
  Dim y As Integer
  
  For x = 1 To edgesWidth - 1
    For y = 1 To edgesHeight - 1
      'horizontal
      If ((Edges(x - 1, y) > 0) And (Edges(x + 1, y) > 0)) Then
        Edges(x, y) = 1
        Else
        'vertical
        If ((Edges(x, y - 1) > 0) And (Edges(x, y + 1) > 0)) Then
          Edges(x, y) = 2
          Else
         'diagonal
         If ((Edges(x - 1, y - 1) > 0) And (Edges(x + 1, y + 1) > 0)) Then
           'Edges(x, y) = 4
           Else
           'diagonal
           If ((Edges(x + 1, y - 1) > 0) And (Edges(x - 1, y + 1) > 0)) Then
             'Edges(x, y) = 3
           End If
         End If
        End If
      End If
      
      If ((Edges(x + 1, y) <> 1) And (Edges(x + 1, y) = Edges(x, y))) Then
        Edges(x, y) = 0
      End If
      If ((Edges(x, y + 1) <> 2) And (Edges(x, y + 1) = Edges(x, y))) Then
        Edges(x, y) = 0
      End If
            
      'surrounded by edges
      If ((Edges(x - 1, y - 1) > 0) And (Edges(x - 1, y) > 0) And (Edges(x - 1, y + 1) > 0) And (Edges(x, y - 1) > 0) And (Edges(x, y + 1) > 0) And (Edges(x + 1, y - 1) > 0) And (Edges(x + 1, y) > 0) And (Edges(x + 1, y + 1) > 0)) Then
        Edges(x, y) = 0
      End If
      
    Next
  Next
  
End Sub


Public Sub init(imageWidth As Integer, imageHeight As Integer)
  width = imageWidth
  height = imageHeight
  ReDim image(width, height)
  
  ReDim edgeTraced(width, height)
  ReDim temp(width, height)
  minEdgeLength = 10
  scanInterval = 1
  
  edgesWidth = width / 2
  edgesHeight = height / 2
  ReDim Edges(edgesWidth, edgesHeight)
  EdgeThreshold = 0
  processType = 0
  Call initEdgeMasks
  averageContrast = 1
  ReDim picked(width, height)
  Histogram_levels = 40
  ReDim ColourHistogram(Histogram_levels)
  ReDim Hist(Histogram_levels)
End Sub


Public Sub setHistogramLevels(levels As Integer)
  Histogram_levels = levels
  ReDim ColourHistogram(Histogram_levels)
  ReDim Hist(Histogram_levels)
End Sub


Public Sub save(FileNumber As Integer)
'save the image
  Dim x As Integer
  Dim y As Integer
  
  Print #FileNumber, width
  Print #FileNumber, height
  For x = 0 To width - 1
    For y = 0 To height - 1
      Print #FileNumber, image(x, y)
    Next
  Next
End Sub


Public Sub load(FileNumber As Integer)
'save the image
  Dim x As Integer
  Dim y As Integer
  Dim b As Byte
  
  Input #FileNumber, width
  Input #FileNumber, height
  Call init(width, height)
  For x = 0 To width - 1
    For y = 0 To height - 1
      Input #FileNumber, b
      image(x, y) = b
    Next
  Next
End Sub


Public Sub whiteNoise()
  Dim x As Integer
  Dim y As Integer
  
  For x = 0 To width - 1
    For y = 0 To height - 1
      image(x, y) = Rnd * 255
    Next
  Next
End Sub


Public Function getPoint(x As Integer, y As Integer) As Byte
  getPoint = image(x, y)
End Function


Public Function setPoint(x As Integer, y As Integer, value As Byte)
  image(x, y) = value
End Function


Public Sub update(canvas As PictureBox, Optional left As Variant, Optional top As Variant, Optional wdth As Variant, Optional hght As Variant)
'import a picture
'processtype = 0   greyscale
'              1   red
'              2   green
'              3   blue
'              4   edges
'              5   movement

  Dim x As Integer
  Dim y As Integer
  Dim screenX As Integer
  Dim screenY As Integer
  Dim w As Integer
  Dim h As Integer
  Dim xx As Integer
  Dim yy As Integer
  Dim value As Double
  Dim RGBval As Long
  Dim pixels As Double
  Dim maxcol As Long
  Dim edgeValue As Single
  Dim screenWidth As Single
  Dim screenHeight As Single
  Dim screenLeft As Single
  Dim screenTop As Single
  Dim rgbsource As RGBthingy
  Dim rgbdest As RGBpoint
  Dim r As Single
  Dim g As Single
  Dim b As Single
    
  If (Not IsMissing(left)) And (Not IsMissing(top)) Then
    screenLeft = left
    screenTop = top
    screenWidth = wdth
    screenHeight = hght
    Else
    screenLeft = 0
    screenTop = 0
    screenWidth = canvas.ScaleWidth
    screenHeight = canvas.ScaleHeight
  End If
  
  w = CInt(screenWidth / width)
  If (w < 1) Then
    w = 1
  End If
  h = CInt(screenHeight / height)
  If (h < 1) Then
    h = 1
  End If

  pixels = w * h
  maxcol = RGB(255, 255, 255)
  For x = 0 To width - 1
    For y = 0 To height - 1
      edgeTraced(x, y) = False
      screenX = screenLeft + ((x / width) * screenWidth)
      screenY = screenTop + ((y / height) * screenHeight)
      value = 0
      For xx = screenX To screenX + w - 1 Step scanInterval
        For yy = screenY To screenY + h - 1 Step scanInterval
          
          RGBval = canvas.Point(xx, yy)
          rgbsource.value = RGBval
          Call CopyMemory(rgbdest, rgbsource, 3)
          r = rgbdest.red
          g = rgbdest.Green
          b = rgbdest.Blue
          Select Case processType
            Case 0  'greyscale
              value = value + ((r + g + b) / 765)
            Case 1  'red
              value = value + (r / 255)
            Case 2  'green
              value = value + (g / 255)
            Case 3  'blue
              value = value + (b / 255)
            Case 5  'motion
              value = value + (RGBval / maxcol)
          End Select
          
        Next
      Next
      value = (value / pixels) * 255
            
      If (processType <> 5) Then
        image(x, y) = value
        Else
        'difference between successive images
        image(x, y) = Abs(value - image(x, y))
      End If
      
    Next
  Next

End Sub



Public Sub updateColourHistogram(canvas As PictureBox, Optional left As Variant, Optional top As Variant, Optional wdth As Variant, Optional hght As Variant)