Not a Member Yet,
Click here to Register

ID: 160
Viewed: 3005
Added: Apr 29, 2002
Version:
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
<!---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.


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 - 2024 snippetlibrary.com All Rights Reserved. Conditions
Do NOT follow this link or you will be banned from the site!