?? classimageprocessing.cls
字號:
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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -