classimageprocessing.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "classImageProcessing"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public width As Integer
Public height As Integer
Dim image() As Byte

Dim edgeTraced() As Boolean
Dim temp() As Boolean
Public TraceEdgesThresh As Integer
Public minEdgeLength As Integer
Dim traceDirection As Single
Dim traceRadius As Integer
Dim traceX As Single
Dim traceY As Single

Dim angleHistogram(18) As Integer

Public edgesWidth As Integer
Public edgesHeight As Integer
Dim Edges() As Byte

Public processType As Integer

Public EdgeThreshold As Single
Dim averageContrast As Double

Const image_raw = 0
Const image_red = 1
Const image_green = 2
Const image_blue = 3
Const image_edges = 4
Const IMAGE_MOVEMENT = 5


Public scanInterval As Integer


'masks used for edge detection
Const NO_OF_EDGE_MASKS = 14
Dim EdgeMask(NO_OF_EDGE_MASKS)
Const NO_OF_EDGE_TYPES = 5
Dim EdgeHistogram(NO_OF_EDGE_TYPES) As Integer

Const EDGE_VECTOR_LENGTH = 200
Dim EdgeVector(5, EDGE_VECTOR_LENGTH) As Single
Dim currEdgeVector As Integer
Dim maxEdgeVectorIntensity As Integer

'colour histogram levels
Dim Histogram_levels As Integer
Dim ColourHistogram() As Double
Dim Hist() As Double


Public Sub showTestCard(pic As PictureBox)
  Dim x As Integer
  Dim maxcol As Long
  Dim col As Long
  
  pic.Cls
  maxcol = RGB(255, 255, 255)
  For x = 0 To pic.ScaleWidth
    col = (maxcol / pic.ScaleWidth) * x
    pic.Line (x, 0)-(x, pic.ScaleHeight), col
  Next
End Sub


Public Function colourSimilarity(pic As PictureBox, topX As Integer, topY As Integer, areaWidth As Integer, areaHeight As Integer) As Single
'compares an area of an image to the colour histogram
  Dim x As Integer
  Dim y As Integer
  Dim RGBvalue As Long
  Dim maxValue As Double
  Dim index As Integer
  Dim max As Double
  Dim similarity As Single
  Dim fract As Single
  Dim i As Integer
  Dim dc As Single
  Dim redValue As Byte
  Dim greenValue As Byte
  Dim blueValue As Byte
  
  'get histogram
  maxValue = RGB(255, 255, 255)
  For x = 0 To areaWidth - 1
    For y = 0 To areaHeight - 1
      RGBvalue = pic.Point(topX + x, topY + y)
      
      If (RGBvalue > 0) Then
        redValue = getRGBvalue(RGBvalue, 0)
        greenValue = getRGBvalue(RGBvalue, 1)
        blueValue = getRGBvalue(RGBvalue, 2)
        index = Int(getSpectrumValue(redValue, greenValue, blueValue) * Histogram_levels)
      
        Hist(index) = Hist(index) + 1
        If (Hist(index) > max) Then
          max = Hist(index)
        End If
      End If
    Next
  Next
  
  'normalize
  If (max > 0.01) Then
    For index = 0 To Histogram_levels - 1
      Hist(index) = Hist(index) / max
    Next
  End If
  
  'compare
  similarity = 0
  i = 0
  For index = 0 To Histogram_levels - 1
    If (ColourHistogram(index) > 0) And (Hist(index) > 0) Then
      dc = Abs(Hist(index) - ColourHistogram(index))
      similarity = similarity + (1 - (dc * dc))
      i = i + 1
    End If
  Next
  If (i > 0) Then
    similarity = similarity / i
  End If
  
  colourSimilarity = similarity
End Function






Private Function traceSearch(Optional beginSearch As Boolean) As Boolean
'move the trace point in a curcular motion until a new feature is found
'returns TRUE when a new feature is located
  
  Dim tx As Integer
  Dim ty As Integer
  
  traceSearch = False
  
  If (beginSearch) Then
    traceDirection = 0
    traceRadius = 90
  End If
  
  traceX = traceX + Cos((traceDirection / 180) * 3.14)
  traceY = traceY + Sin((traceDirection / 180) * 3.14)
  traceDirection = traceDirection + traceRadius
  If (traceDirection > 360) Then
    traceDirection = 0
    traceRadius = traceRadius - 1
    If (traceRadius < 0) Then
      traceRadius = 0
    End If
  End If
  
  If (traceX < 0) Then
    traceX = 0
  End If
  If (traceX >= width) Then
    traceX = width - 1
  End If
  If (traceY < 0) Then
    traceY = 0
  End If
  If (traceY >= height) Then
    traceY = height - 1
  End If
  
  tx = Int(traceX)
  ty = Int(traceY)
  
  If ((image(tx, ty) > TraceEdgesThresh) And (Not edgeTraced(tx, ty))) Then
    traceSearch = True
  End If
End Function


Public Sub showColourHistogram(pic As PictureBox)
  Dim i As Integer
  Dim x As Integer
  Dim y As Integer
  Dim prev_x As Integer
  Dim prev_y As Integer
  Dim c As Long
  
  pic.Cls
  c = RGB(255, 255, 255)
  pic.DrawWidth = 1
  For i = 0 To Histogram_levels
    If (ColourHistogram(i) <= 1) And (ColourHistogram(i) >= 0) Then
      x = (pic.ScaleWidth / Histogram_levels) * i
      y = pic.ScaleHeight - (pic.ScaleHeight * ColourHistogram(i))
      If (i > 0) Then
        pic.Line (prev_x, prev_y)-(x, y), c
      End If
      prev_x = x
      prev_y = y
    End If
  Next
  
End Sub


Private Sub calcAngleHistogram()
'calculates a histogram from the angles of edge traces
  Dim i As Integer
  Dim dx As Integer
  Dim dy As Integer
  Dim length As Integer
  Dim angle As Single
  Dim intensity As Single
  
  
  For i = 0 To 17
    angleHistogram(i) = 0
  Next
    
  For i = 0 To currEdgeVector - 1
    dx = EdgeVector(0, i) - EdgeVector(2, i)
    dy = Abs(EdgeVector(1, i) - EdgeVector(3, i))
    length = Sqr((dx * dx) + (dy * dy))
    If (length > 0) Then
      angle = (Acos(dy / length) / 3.14) * 180
      If (dx < 0) Then
        angle = 180 - angle
      End If
      angle = Int(angle / 10)
      intensity = 1 'EdgeVector(4, i) / 255
      angleHistogram(angle) = angleHistogram(angle) + (length * intensity)
    End If
  Next
  
End Sub


Public Sub applyThreshold(value As Byte)
'applies a threshold to the image
  Dim x As Integer
  Dim y As Integer
  
  For x = 0 To width - 1
    For y = 0 To height - 1
      If (image(x, y) < value) Then
        image(x, y) = 0
      End If
    Next
  Next
End Sub


Private Sub initEdgeMasks()
'defines edge masks
' 1 = horizontal
' 2 = vertical
' 3 = diagonal left
' 4 = diagonal right
' 5 = cross
  
  Dim mask
  Dim i As Integer
  Dim mstr As String
    
  'Lines -
  EdgeMask(0) = Array(1, 1, 1, _
                      0, 0, 0, _
                      0, 0, 0, _
                      1)
  EdgeMask(1) = Array(0, 0, 0, _
                      1, 1, 1, _
                      0, 0, 0, _
                      1)
  EdgeMask(2) = Array(0, 0, 0, _
                      0, 0, 0, _
                      1, 1, 1, _
                      1)
  'Lines |
  EdgeMask(3) = Array(1, 0, 0, _
                      1, 0, 0, _
                      1, 0, 0, _
                      2)
  EdgeMask(4) = Array(0, 1, 0, _
                      0, 1, 0, _
                      0, 1, 0, _
                      2)
  EdgeMask(5) = Array(0, 0, 1, _
                      0, 0, 1, _
                      0, 0, 1, _
                      2)
  'Diagonals
  EdgeMask(6) = Array(0, 0, 1, _
                      0, 1, 0, _
                      1, 0, 0, _
                      3)
  EdgeMask(7) = Array(0, 1, 0, _
                      1, 0, 0, _
                      0, 0, 0, _
                      3)
  EdgeMask(8) = Array(0, 0, 0, _
                      0, 0, 1, _
                      0, 1, 0, _
                      3)
  EdgeMask(9) = Array(1, 0, 0, _
                      0, 1, 0, _
                      0, 0, 1, _
                      4)
  EdgeMask(10) = Array(0, 1, 0, _
                      0, 0, 1, _
                      0, 0, 0, _
                      4)
  EdgeMask(11) = Array(0, 0, 0, _
                      1, 0, 0, _
                      0, 1, 0, _
                      4)
  'Crosses
  EdgeMask(12) = Array(1, 0, 1, _
                      0, 1, 0, _
                      1, 0, 1, _
                      5)
  EdgeMask(13) = Array(0, 1, 0, _
                      1, 1, 1, _
                      0, 1, 0, _
                      5)
  'nothing
  'EdgeMask(14) = Array(0, 0, 0, _
  '                     0, 0, 0, _
  '                     0, 0, 0, _
  '                     0) 'last number indicates edge type
  'EdgeMask(15) = Array(1, 1, 1, _
  '                     1, 1, 1, _
  '                     1, 1, 1, _
  '                     0)
End Sub




Public Sub traceEdges()
'traces edges within the image
  Dim finished As Boolean
  Dim x As Integer
  Dim y As Integer
  Dim traced As Boolean
  
  finished = False
  traced = False
  x = 0
  y = 0
  While (Not finished)
    x = x + 1
    If (x = width) Then
      y = y + 1
      x = 0
    End If
    If (y < height) Then
      If ((edgeTraced(x, y) = False) And (image(x, y) > TraceEdgesThresh)) Then
        traced = traceEdgesFromPoint(x, y, 0)
      End If
      Else
      x = 0
      y = 0
      If (Not traced) Then
        finished = True
      End If
      traced = False
    End If
  Wend
  
  Call sortEdgeVector
  Call calcAngleHistogram
  
End Sub




Private Sub diffuseEdges()
'diffuses edges information
'this allows edge tracing to be more noise tollerant
  Dim x As Integer
  Dim y As Integer
  Dim i As Integer
  Dim value As Integer
  
  For i = 0 To 1
    For x = 1 To width - 2
      For y = 1 To height - 2
        If (image(x, y) > TraceEdgesThresh) Then
          image(x, y) = 255
          
          'value = image(x - 1, y - 1)
          'value = value + image(x - 1, y)
          'value = value + image(x - 1, y + 1)
          'value = value + image(x + 1, y - 1)
          'value = value + image(x + 1, y)
          'value = value + image(x + 1, y + 1)
          'value = value + image(x, y + 1)
          'value = value + image(x, y - 1)
          'value = value / 8
          'image(x, y) = value
        End If
      Next
    Next
  Next
  
End Sub


Public Function traceEdgesFromPoint(ByRef x As Integer, ByRef y As Integer, ByRef edgeLength As Integer) As Boolean
'traces along edges starting at the given point
  Dim i As Integer
  Dim j As Integer
  Dim sx As Integer
  Dim sy As Integer
  Dim xx As Integer
  Dim yy As Integer
  Dim pathFound As Boolean
  Dim initialEdgeLength As Integer
  Dim mindirection As Single
  Dim maxdirection As Single
  Dim initialX As Integer
  Dim initialY As Integer
  Dim max As Integer
  Dim value As Integer
  Dim intensity As Single
  Dim direction As Integer
  Static averagedirection As Single
  Dim directionDifference As Integer
  Dim thresh As Integer
    
  initialX = x
  initialY = y
  xx = initialX
  yy = initialY
  initialEdgeLength = edgeLength
  intensity = 0
  thresh = 0 ' TraceEdgesThresh / 2
  
  If (initialEdgeLength = 0) Then
    For i = 0 To width - 1
      For j = 0 To height - 1
        temp(i, j) = False
      Next
    Next
  End If
  
  averagedirection = 0
  traceEdgesFromPoint = False
  While ((image(xx, yy) > thresh) And (temp(xx, yy) = False))
    sx = xx
    sy = yy
    temp(xx, yy) = True
    edgeLength = edgeLength + 1
    If (edgeTraced(xx, yy) = False) And (edgeLength > minEdgeLength) Then
      traceEdgesFromPoint = True
    End If
    pathFound = False
    max = 0
    
    If (sy > 0) Then
      value = image(sx, sy - 1)
      If ((value > thresh) And (temp(sx, sy - 1) = False)) Then
        If (value > max) And ((averagedirection > 270) Or (averagedirection < 90)) Then
          max = value
          xx = sx
          yy = sy - 1
          direction = 0
        End If
      End If
    End If
    
    If (sx < width - 1) Then
      
      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 > 315) And (averagedirection < 135)) Then
            max = value
            xx = sx
            yy = sy - 1
            direction = 45
          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 > 0) And (averagedirection < 180)) Then
          max = value
          xx = sx + 1
          yy = sy
          direction = 90
        End If
      End If
    
    
      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 > 45) And (averagedirection < 225)) Then
            max = value
            xx = sx