Fastrepcolorbmp

' From a newsgroup posting by Russell Davis
'

Public Sub ReplaceBMColors(ByVal hbmPic As Long, Optional ByVal clrFrom As Long, Optional ByVal clrTo As Long)

Const g0 = 0&
    Dim hdcPic As Long
    Dim hdcMask As Long
    Dim hdcClr As Long
    Dim hbmClr As Long
    Dim hbmClrPrv As Long
    Dim hbmMask As Long
    Dim hbmMaskPrv As Long
    Dim hbmPicPrv As Long
    Dim BitmapPic As Bitmap
    Dim hicCompat As Long

Call OleTranslateColor(clrTo, g0, clrTo)
    GetObjectAPI hbmPic, Len(BitmapPic), BitmapPic
    hicCompat = CreateDisplayIC

hdcPic = CreateCompatibleDC(g0)
    hdcMask = CreateCompatibleDC(g0)
    hdcClr = CreateCompatibleDC(g0)
    With BitmapPic
        hbmClr = CreateCompatibleBitmap(hicCompat, .bmWidth, .bmHeight)
        hbmMask = CreateCompatibleBitmap(hdcMask, .bmWidth, .bmHeight)

hbmMaskPrv = SelectObject(hdcMask, hbmMask)
        hbmClrPrv = SelectObject(hdcClr, hbmClr)
        hbmPicPrv = SelectObject(hdcPic, hbmPic)

SetBkColor hdcPic, clrFrom

BitBlt hdcMask, g0, g0, .bmWidth, .bmHeight, hdcPic, g0, g0, vbSrcCopy

'Mask: clrFrom is white, all else is black
'Set the colors for conversion when Blting from Monochrome Mask to Color
        Pic
'These colors make the Mask be the same in color as it was in monochrome
'(white converts to white, black converts to black)
        SetBkColor hdcPic, vbWhite
        SetTextColor hdcPic, vbBlack
        BitBlt hdcPic, g0, g0, .bmWidth, .bmHeight, hdcMask, g0, g0, vbSrcPaint
'Pic: clrFrom is white, all else is normal
        BitBlt hdcMask, g0, g0, .bmWidth, .bmHeight, hdcMask, g0, g0, vbDstInvert
'Mask: clrFrom is now black, all else is white
        SetBkColor hdcClr, vbWhite
        SetTextColor hdcClr, clrTo
        BitBlt hdcClr, g0, g0, .bmWidth, .bmHeight, hdcMask, g0, g0, vbSrcCopy
'Clr: clrFrom from hdcPic are clrTo; all else is white
        BitBlt hdcPic, g0, g0, .bmWidth, .bmHeight, hdcClr, g0, g0, vbSrcAnd
'Pic: clrFrom is now clrTo, all else is normal
CleanUp:
    End With

SelectObject hdcPic, hbmPicPrv
    DeleteObject SelectObject(hdcMask, hbmMaskPrv)
    DeleteObject SelectObject(hdcClr, hbmClrPrv)
    DeleteDC hdcPic: DeleteDC hdcMask: DeleteDC hdcClr
    DeleteDC hicCompat

End Sub

' From a newsgroup posting by Russell Davis

'

Public Sub ReplaceBMColors(ByVal hbmPic As Long, Optional ByVal clrFrom As Long, Optional ByVal clrTo As Long)

Const g0 = 0&
Dim hdcPic As Long
Dim hdcMask As Long
Dim hdcClr As Long
Dim hbmClr As Long
Dim hbmClrPrv As Long
Dim hbmMask As Long
Dim hbmMaskPrv As Long
Dim hbmPicPrv As Long
Dim BitmapPic As Bitmap
Dim hicCompat As Long

Call OleTranslateColor(clrTo, g0, clrTo)
GetObjectAPI hbmPic, Len(BitmapPic), BitmapPic
hicCompat = CreateDisplayIC

hdcPic = CreateCompatibleDC(g0)
hdcMask = CreateCompatibleDC(g0)
hdcClr = CreateCompatibleDC(g0)
With BitmapPic
hbmClr = CreateCompatibleBitmap(hicCompat, .bmWidth, .bmHeight)
hbmMask = CreateCompatibleBitmap(hdcMask, .bmWidth, .bmHeight)

hbmMaskPrv = SelectObject(hdcMask, hbmMask)
hbmClrPrv = SelectObject(hdcClr, hbmClr)
hbmPicPrv = SelectObject(hdcPic, hbmPic)

SetBkColor hdcPic, clrFrom

BitBlt hdcMask, g0, g0, .bmWidth, .bmHeight, hdcPic, g0, g0, vbSrcCopy

'Mask: clrFrom is white, all else is black

'Set the colors for conversion when Blting from Monochrome Mask to Color

Pic
'These colors make the Mask be the same in color as it was in monochrome

'(white converts to white, black converts to black)

SetBkColor hdcPic, vbWhite
SetTextColor hdcPic, vbBlack
BitBlt hdcPic, g0, g0, .bmWidth, .bmHeight, hdcMask, g0, g0, vbSrcPaint
'Pic: clrFrom is white, all else is normal

BitBlt hdcMask, g0, g0, .bmWidth, .bmHeight, hdcMask, g0, g0, vbDstInvert
'Mask: clrFrom is now black, all else is white

SetBkColor hdcClr, vbWhite
SetTextColor hdcClr, clrTo
BitBlt hdcClr, g0, g0, .bmWidth, .bmHeight, hdcMask, g0, g0, vbSrcCopy
'Clr: clrFrom from hdcPic are clrTo; all else is white

BitBlt hdcPic, g0, g0, .bmWidth, .bmHeight, hdcClr, g0, g0, vbSrcAnd
'Pic: clrFrom is now clrTo, all else is normal

CleanUp:
End With

SelectObject hdcPic, hbmPicPrv
DeleteObject SelectObject(hdcMask, hbmMaskPrv)
DeleteObject SelectObject(hdcClr, hbmClrPrv)
DeleteDC hdcPic: DeleteDC hdcMask: DeleteDC hdcClr
DeleteDC hicCompat

End Sub