CodeItBetter Programming Another VB Programming Blog

'Graphics - How to replace a Color with another Color in Picture Box

'Add a PictureBox and a Command Button to your form and set AutoRedraw property of the Picture Box to True.
'Add Picture to the Picture Box

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
 
Public Sub ReplaceColor(ByRef picThis As PictureBox, ByVal lFromColour As Long, ByVal lToColor As Long)
    Dim lW As Long, lH As Long, lMaskDC As Long, lMaskBMP As Long, lMaskBMPOLd As Long
    Dim lCopyDC As Long, lCopyBMP As Long, lCopyBMPOLd As Long, hBr As Long
    Dim tR As RECT
    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()
    'To replace White color with the Blue color
    Call ReplaceColor(Picture1, vbWhite, vbBlue)
End Sub