Replace All Colors Except One

Picture loaded into a Picturebox.

One Color, say black, I want to keep.
ALL other colors I want to change to one specified color.

e.g.
Keep vbBlack
All other colors changed to vbRed

Looking for a fast way to get this done because of size of picture.
Pixel by pixel is too slow.


I have very fast code to change one color to a different color but I cannot see how to modify it for what I need.
This following code will look for a specific color and replace that color with a specified color.

Public Sub ColorReplace( _
ByRef picThis As PictureBox, _
ByVal lFromColour As Long, _
ByVal lToColor As Long)

'
'

On Error GoTo ColorReplaceErr

Dim lW As Long
Dim lH As Long
Dim lMaskDC As Long
Dim lMaskBMP As Long
Dim lMaskBMPOLd As Long
Dim lCopyDC As Long
Dim lCopyBMP As Long
Dim lCopyBMPOLd As Long
Dim tR As RECT
Dim hBr As Long

' Cache the width & height of the picture:
' lW = picThis.ScaleWidth \ Screen.TwipsPerPixelX
' lH = picThis.ScaleHeight \ Screen.TwipsPerPixelY

lW = picThis.ScaleWidth
lH = picThis.ScaleHeight

' Create a Mono DC & Bitmap
If (CreateDC(picThis, lW, lH, lMaskDC, lMaskBMP, lMaskBMPOLd, True)) Then
' Create a DC & Bitmap with the same colour depth
' as the picture:
If (CreateDC(picThis, lW, lH, lCopyDC, lCopyBMP, lCopyBMPOLd)) Then
' Make a mask from the picture which is white in the
' replace colour area:
SetBkColor picThis.hdc, lFromColour
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hdc, 0, 0, SRCCOPY

' Fill the colour DC with the colour we want to replace with
tR.Right = lW
tR.Bottom = lH
hBr = CreateSolidBrush(lToColor)
FillRect lCopyDC, tR, hBr
DeleteObject hBr
' Turn the colour DC black except where the mask is white:
BitBlt lCopyDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND

' Create an inverted mask, so it is black where the
' color is to be replaced but white otherwise:
hBr = CreateSolidBrush(&HFFFFFF)
FillRect lMaskDC, tR, hBr
DeleteObject hBr
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hdc, 0, 0, SRCINVERT

' AND the inverted mask with the picture. The picture
' goes black where the colour is to be replaced, but is
' unaffected otherwise.
SetBkColor picThis.hdc, &HFFFFFF
BitBlt picThis.hdc, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND

' Finally, OR the coloured item with the picture. Where
' the picture is black and the coloured DC isn't,
' the colour will be transferred:
BitBlt picThis.hdc, 0, 0, lW, lH, lCopyDC, 0, 0, SRCPAINT
picThis.Refresh

' Clear up the colour DC:
SelectObject lCopyDC, lCopyBMPOLd
DeleteObject lCopyBMP
DeleteObject lCopyDC

End If

' Clear up the mask DC:
SelectObject lMaskDC, lMaskBMPOLd
DeleteObject lMaskBMP
DeleteObject lMaskDC

End If

ColorReplaceExit:
Exit Sub

ColorReplaceErr:
DebugAssert
Resume ColorReplaceExit

End Sub 'ColorReplace

Private Function CreateDC( _
ByRef picThis As PictureBox, _
ByVal lW As Long, ByVal lH As Long, _
ByRef lhDC As Long, ByRef lhBmp As Long, ByRef lhBmpOld As Long, _
Optional ByVal bMono As Boolean = False _
) As Boolean

On Error GoTo CreateDCErr

If (bMono) Then
lhDC = CreateCompatibleDC(0)
Else
lhDC = CreateCompatibleDC(picThis.hdc)
End If

If (lhDC <> 0) Then
If (bMono) Then
lhBmp = CreateCompatibleBitmap(lhDC, lW, lH)
Else
lhBmp = CreateCompatibleBitmap(picThis.hdc, lW, lH)
End If
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
CreateDC = True
Else
DeleteObject lhDC
lhDC = 0
End If
End If

CreateDCExit:
Exit Function

CreateDCErr:
DebugAssert
Resume CreateDCExit

End Function 'CreateDC