Replace One Color With Another Color In Picture Box

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 PictureBox and 1 Command Button to your form. Set the Picture Box AutoRedraw
'property to True. Add Picture to the Picture Box or Set The Picture Box BackColor property.
'Insert this code to the module :

Public Type RECT
left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject _
As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCPAINT = &HEE0086
Public Const SRCINVERT = &H660046
Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As _
Long) As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
lpRect As RECT, ByVal hBrush As Long) As Long

'Insert the following code to your form:

Public Sub ReplaceColor(ByRef picThis As PictureBox, _
ByVal lFromColour As Long, ByVal lToColor As Long)
Dim lW As Long
Dim lH As Long
Dim lMaskDC As Long, lMaskBMP As Long, lMaskBMPOLd As Long
Dim lCopyDC As Long, lCopyBMP As Long, lCopyBMPOLd As Long
Dim tR As RECT
Dim hBr As Long
lW = picThis.ScaleWidth \ Screen.TwipsPerPixelX
lH = picThis.ScaleHeight \ Screen.TwipsPerPixelY
If (CreateDC(picThis, lW, lH, lMaskDC, lMaskBMP, lMaskBMPOLd, True)) Then
If (CreateDC(picThis, lW, lH, lCopyDC, lCopyBMP, lCopyBMPOLd)) Then
SetBkColor picThis.hDC, lFromColour
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hDC, 0, 0, SRCCOPY
tR.Right = lW: tR.Bottom = lH
hBr = CreateSolidBrush(lToColor)
FillRect lCopyDC, tR, hBr
DeleteObject hBr
BitBlt lCopyDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND
hBr = CreateSolidBrush(&HFFFFFF)
FillRect lMaskDC, tR, hBr
DeleteObject hBr
BitBlt lMaskDC, 0, 0, lW, lH, picThis.hDC, 0, 0, SRCINVERT
SetBkColor picThis.hDC, &HFFFFFF
BitBlt picThis.hDC, 0, 0, lW, lH, lMaskDC, 0, 0, SRCAND
BitBlt picThis.hDC, 0, 0, lW, lH, lCopyDC, 0, 0, SRCPAINT
picThis.Refresh
SelectObject lCopyDC, lCopyBMPOLd
DeleteObject lCopyBMP
DeleteObject lCopyDC
End If
SelectObject lMaskDC, lMaskBMPOLd
DeleteObject lMaskBMP
DeleteObject lMaskDC
End If
End Sub

Public 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
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
End Function

Private Sub Command1_Click()
'Replace 'vbWhite' with the color you want to change, and 'vbBlue' with the color
'you want to replace the previous color. (you can put here the hex value of  a color. To
'get the color hex value, choose your desirable color in Form Backcolor property and
'copy & Paste the color value from the BackColor cell).

ReplaceColor Picture1, vbWhite, vbBlue
End Sub

Go Back