Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/FILTER.CLS

Text File | 1997-01-03 | 37.1 KB | 1,290 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Filter"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private Bound As Integer
Private Kernel() As Single
Private Wgt As Single
Private Kind As Integer

' Filter types.
Const FILTER_NONE = 0
Const FILTER_LOWPASS = 1
Const FILTER_HIGHPASS = 2
Const FILTER_PREWITT = 3
Const FILTER_LAPLACIAN = 4
Const FILTER_RANK_MIN = 5
Const FILTER_RANK_MEDIAN = 6
Const FILTER_RANK_MAX = 7
Const FILTER_VOTING = 8
Const FILTER_EMBOSS = 9
Const FILTER_MORPHO = 10
Const FILTER_ERODE_OUTLINE = 11
Const FILTER_DILATE_OUTLINE = 12

' Prewitt and embossing filter types.
Const FILTER_UP = 0
Const FILTER_UP_RIGHT = 1
Const FILTER_RIGHT = 2
Const FILTER_DOWN_RIGHT = 3
Const FILTER_DOWN = 4
Const FILTER_DOWN_LEFT = 5
Const FILTER_LEFT = 6
Const FILTER_UP_LEFT = 7

' Morphological filter types.
Const FILTER_EROSION = 10
Const FILTER_DILATION = 11

' ************************************************
' Apply a voting filter.
' ************************************************
Private Sub ApplyVoting(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer
Dim k As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer
Dim arr_size As Integer
Dim brightness() As Integer
Dim index() As Integer
Dim count() As Integer
Dim value As Integer
Dim idx As Integer
Dim best_i As Integer

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Compute the new color values.
    arr_size = 2 * Bound + 1
    arr_size = arr_size * arr_size
    ReDim brightness(1 To arr_size)
    ReDim index(1 To arr_size)
    ReDim count(1 To arr_size)

    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            ' Load values into the brightness and
            ' index arrays.
            idx = 0
            For i = -Bound To Bound
                For j = -Bound To Bound
                    With palentry(bytesin(x + i, y + j))
                        value = CInt(.peRed) + .peGreen + .peBlue
                    End With
                    For k = 1 To idx
                        If brightness(k) = value Then
                            count(k) = count(k) + 1
                            Exit For
                        End If
                    Next k
                    If k > idx Then
                        idx = idx + 1
                        count(idx) = 1
                        brightness(idx) = value
                        index(idx) = bytesin(x + i, y + j)
                    End If
                Next j
            Next i
            ' See which value got the most votes.
            value = count(1)
            best_i = 1
            For i = 2 To idx
                If value < count(i) Then
                    value = count(i)
                    best_i = i
                End If
            Next i

            ' Set the new pixel value.
            bytesout(x, y) = index(best_i)
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub

' ************************************************
' Apply a median filter.
' ************************************************
Private Sub ApplyRank(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer
Dim arr_size As Integer
Dim brightness() As Integer
Dim index() As Integer
Dim idx As Integer
Dim tmp As Integer
Dim best_brightness As Long
Dim best_j As Integer

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Compute the new color values.
    arr_size = 2 * Bound + 1
    arr_size = arr_size * arr_size
    ReDim brightness(1 To arr_size)
    ReDim index(1 To arr_size)

    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            ' Load values into the brightness and
            ' index arrays.
            idx = 1
            For i = -Bound To Bound
                For j = -Bound To Bound
                    With palentry(bytesin(x + i, y + j))
                        brightness(idx) = CInt(.peRed) + .peGreen + .peBlue
                    End With
                    index(idx) = bytesin(x + i, y + j)
                    idx = idx + 1
                Next j
            Next i
            ' Sort the pixels by brightness.
            For i = 1 To arr_size - 1
                best_brightness = brightness(i)
                best_j = i
                For j = i + 1 To arr_size
                    If brightness(j) > brightness(i) Then
                        best_brightness = brightness(j)
                        best_j = j
                    End If
                Next j
                ' Swap the i and best_j positions.
                brightness(best_j) = brightness(i)
                brightness(i) = best_brightness
                tmp = index(best_j)
                index(best_j) = index(i)
                index(i) = tmp
            Next i

            ' Set output value based on rank.
            Select Case Kind
                Case FILTER_RANK_MIN
                    bytesout(x, y) = index(1)
                Case FILTER_RANK_MEDIAN
                    bytesout(x, y) = index(5)
                Case FILTER_RANK_MAX
                    bytesout(x, y) = index(9)
            End Select
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub


' ************************************************
' Create an outline by subtracting an eroded image
' from the original.
' ************************************************
Private Sub ApplyErodeOutline(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer
Dim c As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Do the erosion.
    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            For i = -Bound To Bound
                For j = -Bound To Bound
                    If palentry(bytesin(x + i, y + j)).peRed <> Kernel(i, j) Then Exit For
                Next j
                If j <= Bound Then Exit For
            Next i
            If j <= Bound Then
                c = bytesin(x, y) - (255 - Wgt)
            Else
                c = bytesin(x, y) - Wgt
            End If
            If c < 0 Then c = 0
            bytesout(x, y) = GetNearestPaletteIndex( _
                hPal, RGB(c, c, c) + &H2000000)
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub

' ************************************************
' Display a message box describing dilated
' outlines.
' ************************************************
Sub ShowDilateOutline()
    MsgBox "This filter creates an outline by subtracting" & _
        "the original image from a dilated version.", _
        vbInformation, "Filter Values"
End Sub

' ************************************************
' Display a message box describing edoded
' outlines.
' ************************************************
Sub ShowErodeOutline()
    MsgBox "This filter creates an outline by " & _
        "subtracting an eroded image from the original.", _
        vbInformation, "Filter Values"
End Sub


' ************************************************
' Create an outline by subtracting the original
' image from a dilated image.
' ************************************************
Private Sub ApplyDilateOutline(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer
Dim c As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Do the erosion.
    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            For i = -Bound To Bound
                For j = -Bound To Bound
                    If palentry(bytesin(x + i, y + j)).peRed <> Kernel(i, j) Then Exit For
                Next j
                If j <= Bound Then Exit For
            Next i
            If j <= Bound Then
                c = (255 - Wgt) - bytesin(x, y)
            Else
                c = Wgt - bytesin(x, y)
            End If
            If c < 0 Then c = 0
            bytesout(x, y) = GetNearestPaletteIndex( _
                hPal, RGB(c, c, c) + &H2000000)
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub

' ************************************************
' Apply a morphological filter.
'
' Give the output pixel the value Wgt if the
' area's pixels match the kernel. Otherwise give
' it value 255 - Wgt.
' ************************************************
Private Sub ApplyMorpho(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer
Dim c As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Compute the new color values.
    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            For i = -Bound To Bound
                For j = -Bound To Bound
                    If palentry(bytesin(x + i, y + j)).peRed <> Kernel(i, j) Then Exit For
                Next j
                If j <= Bound Then Exit For
            Next i
            If j <= Bound Then
                c = 255 - Wgt
            Else
                c = Wgt
            End If
            bytesout(x, y) = GetNearestPaletteIndex( _
                hPal, RGB(c, c, c) + &H2000000)
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub




' ************************************************
' Apply an embossing filter. This is just like a
' normal filter except we add 127 to each new
' pixel value to give the image a gray background.
' ************************************************
Private Sub ApplyEmboss(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer
Dim r As Long
Dim g As Long
Dim b As Long

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Compute the new color values.
    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            r = 0
            g = 0
            b = 0
            For i = -Bound To Bound
                For j = -Bound To Bound
                    With palentry(bytesin(x + i, y + j))
                        r = r + Kernel(i, j) * .peRed
                        g = g + Kernel(i, j) * .peGreen
                        b = b + Kernel(i, j) * .peBlue
                    End With
                Next j
            Next i
            r = r / Wgt + 127
            g = g / Wgt + 127
            b = b / Wgt + 127
            If r < 0 Then r = 0
            If g < 0 Then g = 0
            If b < 0 Then b = 0
            bytesout(x, y) = GetNearestPaletteIndex( _
                hPal, RGB(r, g, b) + &H2000000)
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub



' ************************************************
' Apply a normal filter.
' ************************************************
Private Sub ApplyNormal(from_pict As Object, to_pict As Object, show_progress As Boolean)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytesin() As Byte
Dim bytesout() As Byte
Dim wid As Long
Dim hgt As Long
Dim i As Integer
Dim j As Integer

Dim hPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer
Dim r As Long
Dim g As Long
Dim b As Long

    ' *****************************
    ' * Get the input bitmap data *
    ' *****************************
    ' Get a handle to the input bitmap.
    hbm = from_pict.Image

    ' See how big it is.
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight

    ' Get the bits.
    ReDim bytesin(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, bytesin(0, 0))
    ReDim bytesout(0 To wid - 1, 0 To hgt - 1)

    ' ********************
    ' * Apply the filter *
    ' ********************
    ' Get the current color values.
    hPal = from_pict.Picture.hPal
    i = GetPaletteEntries(hPal, 0, 255, palentry(0))

    ' Compute the new color values.
    For x = Bound To wid - 1 - Bound
        ' If the operation has been canceled, stop.
        DoEvents
        If Not OperationRunning Then Exit For

        ' If we should show progress, do so.
        If show_progress Then
            status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
            to_pict.Refresh
        End If

        For y = Bound To hgt - 1 - Bound
            r = 0
            g = 0
            b = 0
            For i = -Bound To Bound
                For j = -Bound To Bound
                    With palentry(bytesin(x + i, y + j))
                        r = r + Kernel(i, j) * .peRed
                        g = g + Kernel(i, j) * .peGreen
                        b = b + Kernel(i, j) * .peBlue
                    End With
                Next j
            Next i
            r = r / Wgt
            g = g / Wgt
            b = b / Wgt
            If r < 0 Then r = 0
            If g < 0 Then g = 0
            If b < 0 Then b = 0
            bytesout(x, y) = GetNearestPaletteIndex( _
                hPal, RGB(r, g, b) + &H2000000)
        Next y
    Next x

    ' **********************
    ' * Display the output *
    ' **********************
    status = SetBitmapBits(to_pict.Image, wid * hgt, bytesout(0, 0))
    to_pict.Refresh
End Sub



' ************************************************
' Display a message box giving the filter's
' dimensions.
' ************************************************
Public Sub ShowVoting()
Dim numstr As String
Dim txt As String

    numstr = Format$(2 * Bound + 1)
    txt = "This is a " & numstr & "x" & numstr & _
        " voting filter."
    MsgBox txt, vbInformation, "Filter Values"
End Sub
' ************************************************
' Display a message box describing a morphological
' filter.
' ************************************************
Public Sub ShowMorpho()
Dim txt As String
Dim numstr As String
Dim maxlen As Integer
Dim x As Integer
Dim y As Integer

    ' See how long the biggest number is.
    maxlen = 0
    For y = -Bound To Bound
        For x = -Bound To Bound
            numstr = Format$(Kernel(x, y))
            If maxlen < Len(numstr) Then maxlen = Len(numstr)
        Next x
    Next y

    ' Build the message to display.
    For y = -Bound To Bound
        For x = -Bound To Bound
            numstr = Format$(Kernel(x, y))
            txt = txt & _
                Space$(maxlen - Len(numstr)) & _
                numstr & " "
        Next x
        txt = txt & vbCrLf
    Next y

    txt = txt & vbCrLf & _
        "If all value match:" & Str$(Wgt)
    txt = txt & vbCrLf & _
        "Otherwise:         " & Str$(255 - Wgt)

    MsgBox txt, vbInformation, "Filter Values"
End Sub

' ************************************************
' Display a message box giving the filter's
' dimensions.
' ************************************************
Public Sub ShowRank(rank_type As Integer)
Dim numstr As String
Dim typestr As String
Dim txt As String

    numstr = Format$(2 * Bound + 1)
    Select Case rank_type
        Case 0
            typestr = " minimum "
        Case 1
            typestr = " median "
        Case 2
            typestr = " maximum "
    End Select

    txt = "This is a " & numstr & "x" & _
        numstr & typestr & "filter."
    MsgBox txt, vbInformation, "Filter Values"
End Sub


' ************************************************
' Display a message box showing the filter's
' components and weight.
' ************************************************
Public Sub ShowNormal()
Dim txt As String
Dim numstr As String
Dim maxlen As Integer
Dim x As Integer
Dim y As Integer

    ' See how long the biggest number is.
    maxlen = 0
    For y = -Bound To Bound
        For x = -Bound To Bound
            numstr = Format$(Kernel(x, y), "0.00")
            If maxlen < Len(numstr) Then maxlen = Len(numstr)
        Next x
    Next y

    ' Build the message to display.
    For y = -Bound To Bound
        For x = -Bound To Bound
            numstr = Format$(Kernel(x, y), "0.00")
            txt = txt & _
                Space$(maxlen - Len(numstr)) & _
                numstr & " "
        Next x
        txt = txt & vbCrLf
    Next y
    txt = txt & vbCrLf & "Weight:" & Str$(Wgt)

    MsgBox txt, vbInformation, "Filter Values"
End Sub



' ************************************************
' Display a message box describing the filter.
' ************************************************
Public Sub ShowFilter()
    Select Case Kind
        Case FILTER_LOWPASS, FILTER_HIGHPASS, _
             FILTER_PREWITT, FILTER_LAPLACIAN, _
             FILTER_EMBOSS
            ShowNormal

        Case FILTER_RANK_MIN
            ShowRank 0

        Case FILTER_RANK_MEDIAN
            ShowRank 1

        Case FILTER_RANK_MAX
            ShowRank 2

        Case FILTER_VOTING
            ShowVoting

        Case FILTER_MORPHO
            ShowMorpho

        Case FILTER_ERODE_OUTLINE
            ShowErodeOutline

        Case FILTER_DILATE_OUTLINE
            ShowDilateOutline
    End Select
End Sub



' ************************************************
' Initialize the filter based on its name.
' ************************************************
Sub InitializeFilter(filtername As String)
    Select Case filtername
        Case "Average 3x3"
            InitializeAverage 3

        Case "Low Pass 3x3"
            InitializeLowPass 3
        Case "Low Pass 5x5"
            InitializeLowPass 5
        Case "Low Pass 7x7"
            InitializeLowPass 7

        Case "High Pass 1"
            InitializeHighPass 1
        Case "High Pass 2"
            InitializeHighPass 2
        Case "High Pass 3"
            InitializeHighPass 3
        Case "High Pass 4"
            InitializeHighPass 4

        Case "Prewitt Up"
            InitializePrewitt FILTER_UP
        Case "Prewitt Up-Right"
            InitializePrewitt FILTER_UP_RIGHT
        Case "Prewitt Right"
            InitializePrewitt FILTER_RIGHT
        Case "Prewitt Down-Right"
            InitializePrewitt FILTER_DOWN_RIGHT
        Case "Prewitt Down"
            InitializePrewitt FILTER_DOWN
        Case "Prewitt Down-Left"
            InitializePrewitt FILTER_DOWN_LEFT
        Case "Prewitt Left"
            InitializePrewitt FILTER_LEFT
        Case "Prewitt Up-Left"
            InitializePrewitt FILTER_UP_LEFT

        Case "Laplacian 1"
            InitializeLaplacian 1
        Case "Laplacian 2"
            InitializeLaplacian 2

        Case "Minimum 3x3"
            Kind = FILTER_RANK_MIN
            Bound = 1
        Case "Median 3x3"
            Kind = FILTER_RANK_MEDIAN
            Bound = 1
        Case "Maximum 3x3"
            Kind = FILTER_RANK_MAX
            Bound = 1

        Case "Voting 3x3"
            InitializeVoting 3

        Case "Emboss Up"
            InitializeEmboss FILTER_UP
        Case "Emboss Up-Right"
            InitializeEmboss FILTER_UP_RIGHT
        Case "Emboss Right"
            InitializeEmboss FILTER_RIGHT
        Case "Emboss Down-Right"
            InitializeEmboss FILTER_DOWN_RIGHT
        Case "Emboss Down"
            InitializeEmboss FILTER_DOWN
        Case "Emboss Down-Left"
            InitializeEmboss FILTER_DOWN_LEFT
        Case "Emboss Left"
            InitializeEmboss FILTER_LEFT
        Case "Emboss Up-Left"
            InitializeEmboss FILTER_UP_LEFT

        ' Morphological filters.
        Case "Erosion"
            InitializeMorpho FILTER_EROSION
        Case "Dilation"
            InitializeMorpho FILTER_DILATION

        ' Outlines.
        Case "Erosion Outline"
            InitializeErodeOutline
        Case "Dilation Outline"
            InitializeDilateOutline
    End Select
End Sub


' ************************************************
' Apply the filter to an array of bits.
' ************************************************
Public Sub ApplyFilter(from_pict As Object, to_pict As Object, show_progress As Boolean)
    Select Case Kind
        Case FILTER_NONE
            Beep
            MsgBox "This filter is undefined.", vbExclamation

        Case FILTER_LOWPASS, FILTER_HIGHPASS, _
             FILTER_PREWITT, FILTER_LAPLACIAN
            ApplyNormal from_pict, to_pict, show_progress

        Case FILTER_EMBOSS
            ApplyEmboss from_pict, to_pict, show_progress

        Case FILTER_RANK_MEDIAN, FILTER_RANK_MIN, _
             FILTER_RANK_MAX
            ApplyRank from_pict, to_pict, show_progress

        Case FILTER_VOTING
            ApplyVoting from_pict, to_pict, show_progress

        Case FILTER_MORPHO
            ApplyMorpho from_pict, to_pict, show_progress

        Case FILTER_ERODE_OUTLINE
            ApplyErodeOutline from_pict, to_pict, show_progress

        Case FILTER_DILATE_OUTLINE
            ApplyDilateOutline from_pict, to_pict, show_progress

    End Select
End Sub
' ************************************************
' Initialize a high pass (sharpening) filter.
' ************************************************
Public Sub InitializeHighPass(high_kind As Integer)
Dim r As Integer
Dim c As Integer

    Kind = FILTER_HIGHPASS
    Bound = 1
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    Select Case high_kind
        Case 1
            For r = -Bound To Bound
                For c = -Bound To Bound
                    Kernel(r, c) = -1
                Next c
            Next r
            Kernel(0, 0) = 9
            Wgt = 1

        Case 2
            Kernel(-1, -1) = 0
            Kernel(-1, 0) = -1
            Kernel(-1, 1) = 0
            Kernel(0, -1) = -1
            Kernel(0, 0) = 5
            Kernel(0, 1) = -1
            Kernel(1, -1) = 0
            Kernel(1, 0) = -1
            Kernel(1, 1) = 0
            Wgt = 1

        Case 3
            Kernel(-1, -1) = 1
            Kernel(-1, 0) = -2
            Kernel(-1, 1) = 1
            Kernel(0, -1) = -2
            Kernel(0, 0) = 5
            Kernel(0, 1) = -2
            Kernel(1, -1) = 1
            Kernel(1, 0) = -2
            Kernel(1, 1) = 1
            Wgt = 1

        Case 4
            For r = -Bound To Bound
                For c = -Bound To Bound
                    Kernel(r, c) = -1
                Next c
            Next r
            Kernel(0, 0) = 15
            Wgt = Kernel(0, 0) - 8

        Case Else
            ' Flag the filter as uninitialized.
            Kind = FILTER_NONE
            Wgt = 1

    End Select
End Sub

' ************************************************
' Initialize a voting filter.
' ************************************************
Public Sub InitializeVoting(size As Integer)
    Kind = FILTER_VOTING
    Bound = size \ 2
End Sub

' ************************************************
' Initialize an averaging (blurring) filter.
' ************************************************
Public Sub InitializeAverage(size As Integer)
Dim r As Integer
Dim c As Integer

    Kind = FILTER_LOWPASS
    Bound = size \ 2
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    For r = -Bound To Bound
        For c = -Bound To Bound
            Kernel(r, c) = 1
        Next c
    Next r
    Wgt = (2 * Bound + 1) * (2 * Bound + 1)
End Sub



' ************************************************
' Initialize a 3x3 Laplacian filter.
' ************************************************
Public Sub InitializeLaplacian(laplacian_type As Integer)
Dim r As Integer
Dim c As Integer

    Kind = FILTER_LAPLACIAN
    Bound = 1
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    Select Case laplacian_type
        Case 1
            For r = -Bound To Bound
                For c = -Bound To Bound
                    Kernel(r, c) = -1
                Next c
            Next r
            Kernel(0, 0) = 8

        Case 2
            Kernel(-1, -1) = 0
            Kernel(0, -1) = -1
            Kernel(1, -1) = 0
            Kernel(-1, 0) = -1
            Kernel(0, 0) = 4
            Kernel(1, 0) = -1
            Kernel(-1, 1) = 0
            Kernel(0, 1) = -1
            Kernel(1, 1) = 0

    End Select
    Wgt = 1
End Sub

' ************************************************
' Initialize a 3x3 dilation filter for use when
' creating an outline using dilation.
' ************************************************
Public Sub InitializeDilateOutline()
    InitializeMorpho FILTER_DILATION
    Kind = FILTER_DILATE_OUTLINE
End Sub
' ************************************************
' Initialize a 3x3 erosion filter for use when
' creating an outline using erosion.
' ************************************************
Public Sub InitializeErodeOutline()
    InitializeMorpho FILTER_EROSION
    Kind = FILTER_ERODE_OUTLINE
End Sub




' ************************************************
' Initialize a 3x3 morphological filter.
' ************************************************
Public Sub InitializeMorpho(morpho_type As Integer)
Dim r As Integer
Dim c As Integer

    Kind = FILTER_MORPHO
    Bound = 1
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    Select Case morpho_type
        Case FILTER_EROSION
            For r = -Bound To Bound
                For c = -Bound To Bound
                    Kernel(r, c) = 255
                Next c
            Next r
            Wgt = 255

        Case FILTER_DILATION
            For r = -Bound To Bound
                For c = -Bound To Bound
                    Kernel(r, c) = 0
                Next c
            Next r
            Wgt = 0
    End Select
End Sub



' ************************************************
' Initialize a 3x3 embossing filter.
' ************************************************
Public Sub InitializeEmboss(emboss_type As Integer)
Dim r As Integer
Dim c As Integer

    Kind = FILTER_EMBOSS
    Bound = 1
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    For r = -Bound To Bound
        For c = -Bound To Bound
            Kernel(r, c) = 0
        Next c
    Next r

    Select Case emboss_type
        Case FILTER_UP
            Kernel(0, -1) = 1: Kernel(0, 1) = -1
        Case FILTER_UP_RIGHT
            Kernel(-1, 1) = -1: Kernel(1, -1) = 1
        Case FILTER_RIGHT
            Kernel(1, 0) = 1: Kernel(-1, 0) = -1
        Case FILTER_DOWN_RIGHT
            Kernel(-1, -1) = -1: Kernel(1, 1) = 1
        Case FILTER_DOWN
            Kernel(0, -1) = -1: Kernel(0, 1) = 1
        Case FILTER_DOWN_LEFT
            Kernel(-1, 1) = 1: Kernel(1, -1) = -1
        Case FILTER_LEFT
            Kernel(1, 0) = -1: Kernel(-1, 0) = 1
        Case FILTER_UP_LEFT
            Kernel(-1, -1) = 1: Kernel(1, 1) = -1
    End Select
    Wgt = 1
End Sub



' ************************************************
' Initialize a 3x3 Prewitt filter.
' ************************************************
Public Sub InitializePrewitt(prewitt_type As Integer)
Dim r As Integer
Dim c As Integer

    Kind = FILTER_PREWITT
    Bound = 1
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    For r = -Bound To Bound
        For c = -Bound To Bound
            Kernel(r, c) = 1
        Next c
    Next r
    Kernel(0, 0) = -2

    Select Case prewitt_type
        Case FILTER_UP
            Kernel(-1, 1) = -1: Kernel(0, 1) = -1: Kernel(1, 1) = -1
        Case FILTER_UP_RIGHT
            Kernel(-1, 0) = -1: Kernel(-1, 1) = -1: Kernel(0, 1) = -1
        Case FILTER_RIGHT
            Kernel(-1, -1) = -1: Kernel(-1, 0) = -1: Kernel(-1, 1) = -1
        Case FILTER_DOWN_RIGHT
            Kernel(-1, -1) = -1: Kernel(-1, 0) = -1: Kernel(0, -1) = -1
        Case FILTER_DOWN
            Kernel(-1, -1) = -1: Kernel(0, -1) = -1: Kernel(1, -1) = -1
        Case FILTER_DOWN_LEFT
            Kernel(0, -1) = -1: Kernel(1, -1) = -1: Kernel(1, 0) = -1
        Case FILTER_LEFT
            Kernel(1, -1) = -1: Kernel(1, 0) = -1: Kernel(1, 1) = -1
        Case FILTER_UP_LEFT
            Kernel(0, 1) = -1: Kernel(1, 0) = -1: Kernel(1, 1) = -1
    End Select
    Wgt = 1
End Sub



' ************************************************
' Initialize a low pass (blurring) filter.
' ************************************************
Public Sub InitializeLowPass(size As Integer)
Dim r As Integer
Dim c As Integer
Dim vr As Integer

    Kind = FILTER_LOWPASS
    Bound = size \ 2
    ReDim Kernel(-Bound To Bound, -Bound To Bound)

    For r = -Bound To Bound
        vr = Bound + 1 - Abs(r)
        For c = -Bound To Bound
            Kernel(r, c) = vr * (Bound + 1 - Abs(c))
            Wgt = Wgt + Kernel(r, c)
        Next c
    Next r
End Sub




' ************************************************
' Flag the filter as uninitialized.
' ************************************************
Private Sub Class_Initialize()
    Kind = FILTER_NONE
End Sub