ID: 160
Viewed: 3005
Added: Apr 29, 2002
Version:
Snippet uploaded by: snippet
Written By: unknown
Demo: Sorry, no demo
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
<!---Declaration--->
'
' 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
Highlight All
<!---Code--->
none;
No Comments to show
Please completely fill out the form below if you want to review this snippet. All reviews are subject to validation.
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.