PictureBox Replace Color

[Krool]

Hello,

herewith I want to share a function that just replace a color in a PictureBox.
I have found way more complicated ways to do that. I think this way is pretty short and not complicated.

' SAMPLE IN A FORM
Option Explicit

Private Sub Form_Load()
Call PictureBoxReplaceColor(Picture1, RGB(255, 255, 255), vbMenuBar)
' This replaces for example a white color to the windows system menu color
' Usefull if you want to put a picture to a popupmenu (-> SetMenuItemBitmaps)
End Sub

' FUNCTION; PUT IN MODULE
Option Explicit
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal Color As Long, ByVal hPal As Long, ByRef RGBResult As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

Public Sub PictureBoxReplaceColor(ByVal PictureBox As VB.PictureBox, ByVal FromColor As Long, ByVal ToColor As Long)
If PictureBox.Picture Is Nothing Then Err.Raise Number:=1, Description:="Picture not set"
If PictureBox.Picture.Handle = 0 Then Err.Raise Number:=2, Description:="Picture handle is null"
Dim WinFromColor As Long, WinToColor As Long, MemAutoRedraw As Boolean
WinFromColor = WinColor(FromColor)
WinToColor = WinColor(ToColor)
With PictureBox
MemAutoRedraw = .AutoRedraw
.AutoRedraw = True
Dim X As Long, Y As Long
For X = 0 To CInt(.ScaleX(.Picture.Width, vbHimetric, vbPixels))
    For Y = 0 To CInt(.ScaleY(.Picture.Height, vbHimetric, vbPixels))
        If GetPixel(.hDC, X, Y) = WinFromColor Then SetPixel .hDC, X, Y, WinToColor
    Next Y
Next X
.Refresh
.Picture = .Image
.AutoRedraw = MemAutoRedraw
End With
End Sub

Public Function WinColor(ByVal Color As Long, Optional ByVal hPal As Long) As Long
If OleTranslateColor(Color, hPal, WinColor) <> 0 Then WinColor = -1
End Function