Ok, I suspect a few have been following my little project. I'm making a great deal of progress, but I've run across a small snag.

To do some smoothing/contouring of a certain image, I'm using what is known as a Median Noise Filter. I'm happy with the filter I've developed. It's just that it runs slow.

The slowness has to do with calculating a median of surrounding pixels for every pixel on the image.

The following is some demo code that shows the median filter algorithm.

I'm specifically interested in speeding up that call to bbDoContouring. And it also calls bbInsertionSort. I think there may be a way to determine a median without doing a sort, and I'll be exploring that.

However, if anyone has ideas on how to make that bbDoContouring run faster, I'm listening.

Code:

Option Explicit
'
Private Type BmpInfoHeader
    biSize            As Long
    biWidth           As Long
    biHeight          As Long
    biPlanes          As Integer
    biBitCount        As Integer
    biCompression     As Long
    biSizeImage       As Long
    biXPelsPerMeter   As Long
    biYPelsPerMeter   As Long
    biClrUsed         As Long
    biClrImportant    As Long
End Type
'
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Srcdx As Long, ByVal Srcdy As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long
'
Dim mlPalette()         As Long
Dim muBmpInfoHeader     As BmpInfoHeader
Dim mlDibPels()         As Long     ' Kept out here so we can DIM it once, for performance.
'
Dim bbArray1() As Byte
Dim bbArray2() As Byte
'


Private Sub Form_Click()
    Static bAlreadyDone As Boolean
    If bAlreadyDone Then
        MsgBox "Already Done"
        Exit Sub
    End If
    bAlreadyDone = True



    bbDoContouring bbArray1, bbArray2       ' <----- **** NEED TO SPEED THIS UP ****



    FrameToDib bbArray2, mlPalette, mlDibPels
    DrawDibFrame
End Sub


Private Sub bbDoContouring(bbIn() As Byte, bbOut() As Byte)
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim bb As Byte
    Dim bbSort(28&) As Byte
    '
    ReDim bbOut(LBound(bbIn, 1&) To UBound(bbIn, 1&), LBound(bbIn, 2&) To UBound(bbIn, 2&))
    '
    On Error Resume Next        ' Easy way to deal with boundaries of picture.
        For i = LBound(bbIn, 1&) To UBound(bbIn, 1&)
            For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)
                ' First, fill all the sort values with the target value.
                For k = 0& To 28&
                    bbSort(k) = bbIn(i, j)
                Next k
                ' Now, get surrounding values, erroring when we're out of bounds.
                bbSort(0&) = bbIn(i, j - 3&)
                bbSort(1&) = bbIn(i, j + 3&)
                bbSort(2&) = bbIn(i - 3&, j)
                bbSort(3&) = bbIn(i + 3, j)
                n = 4&
                For k = -2 To 2
                    For m = -2 To 2
                        bbSort(n) = bbIn(i + k, j + m)
                        n = n + 1&
                    Next
                Next
                '
                bbInsertionSort bbSort, 29&     ' We've gathered the sort array, so sort it.  Insertion sort.
                bbOut(i, j) = bbSort(14&)       ' Pluck the median and insert in the destination.
            Next
        Next
    On Error GoTo 0
End Sub

Private Sub bbInsertionSort(bbSort() As Byte, n As Long)
    Dim bb  As Byte
    Dim i   As Long
    Dim j   As Long
    '
    For i = 1& To n - 1&
        bb = bbSort(i)
        j = i - 1&
        Do
            If j < 0& Then Exit Do
            If bbSort(j) > bb Then Exit Do
            bbSort(j + 1&) = bbSort(j)
            j = j - 1&
        Loop
        bbSort(j + 1&) = bb
    Next
End Sub






Private Sub Form_Activate()
    ReDim mlPalette(255)
    SetPaletteForBmpBracket mlPalette
    ' Setup all but size in our BmpInfoHeader.
    muBmpInfoHeader.biSize = LenB(muBmpInfoHeader)
    muBmpInfoHeader.biPlanes = 1
    muBmpInfoHeader.biBitCount = 32
    '
    '
    Dim i As Long, j As Long
    '
    Randomize 1234
    ReDim bbArray1(499, 499)
    ReDim mlDibPels(499, 499)

    ' Random noise.
    For i = 0 To 499
        For j = 0 To 499
            bbArray1(i, j) = Int(Rnd * 256)
        Next
    Next
    '
    ' Show it.
    FrameToDib bbArray1, mlPalette, mlDibPels
    DrawDibFrame
End Sub

Private Sub SetPaletteForBmpBracket(lPalette() As Long)
    Dim iColors(1 To 16) As Long
    Dim j As Long
    Dim i As Long
    '
    ' These are directly from Tekscan.
    iColors(1) = &HFF&
    iColors(2) = &H66FF&
    iColors(3) = &H99FF&
    iColors(4) = &H33CCFF
    iColors(5) = &HFFFF&
    iColors(6) = &HFFCC&
    iColors(7) = &HFF99&
    iColors(8) = &HFF00&
    iColors(9) = &H99FF33
    iColors(10) = &HFFFF00
    iColors(11) = &HFFCC00
    iColors(12) = &HFF9900
    iColors(13) = &HFF6600
    iColors(14) = &HFF3300
    iColors(15) = &H990000
    iColors(16) = &H660000
    '
    ' Make sure we have black.
    lPalette(0) = &H0&
    ' Make sure we have white.
    lPalette(1) = &HFFFFFF
    ' Make sure we have red (a dark red here).
    lPalette(2) = &HBB&
    '
    For i = 3& To 255& ' This is allowed data range.
        j = (i - 3&) \ 16& + 1&
        lPalette(i) = iColors(j)
    Next
End Sub

Private Sub FrameToDib(bbFrame() As Byte, lPalette() As Long, lDibPels() As Long)
    ' If lDibPels MUST come in dimensioned the same size as bbFrame.
    ' It's done this way to keep performance up.
    '
    Dim j As Long
    Dim i As Long
    '
    For j = LBound(bbFrame, 2&) To UBound(bbFrame, 2&)
        For i = LBound(bbFrame, 1&) To UBound(bbFrame, 1&)
            lDibPels(i, j) = lPalette(bbFrame(i, j))
        Next
    Next
End Sub

Private Sub DrawDibFrame()
    Dim w As Long
    Dim h As Long
    Dim lDrawWidth As Long
    Dim lDrawHeight As Long
    '
    w = UBound(mlDibPels, 1&) + 1&
    h = UBound(mlDibPels, 2&) + 1&
    '
    lDrawWidth = w
    lDrawHeight = h
    '
    muBmpInfoHeader.biWidth = w
    muBmpInfoHeader.biHeight = -h
    '
    Me.AutoRedraw = True
    Me.Cls
    Me.Picture = LoadPicture() ' The old picture is remembered by VB if we don't do this.
    '
    StretchDIBits Me.hDC, 0&, 0&, lDrawWidth, lDrawHeight, 0&, 0&, w, h, mlDibPels(0&, 0&), muBmpInfoHeader, 0&, vbSrcCopy
End Sub

Basically, just throw that code into Form1. It will show a noise image on Form_Load, and then do the filtering on Form_Click. It's the Form_Click where things are slow.

Thanks,
Elroy