Not a Member Yet,
Click here to Register
How do you like the new design?

ID: 160
Viewed: 2466
Added: Apr 29, 2002
Snippet uploaded by: snippet
Written By: unknown
Demo: Sorry, no demo

User Rated at: 0 Stars
Rate This:

Thank you for your vote. Please wait...

It appears you already voted for this snippet

It appears your vote value was empty

Fast replace one color in a bitmap with another

Highlight all by clicking in box
' 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
'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
End With

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

End Sub

Highlight All

No Comments to show

Please completely fill out the form below if you want to review this snippet. All reviews are subject to validation.

Replying to a Comment...

Adding your comment. Please wait...

Thanks for adding your comment!. After further review it will be added.

There was a problem adding your comment. Please try again.

Please complete all the fields in the form before sending.

© 2002 - 2017 All Rights Reserved. Conditions