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 Type OLECOLOR
RedOrSys As Byte
Green As Byte
Blue As Byte
Type As Byte
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex 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.Handle = 0 Then Err.Raise Number:=1, Description:="Picture 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) As Long
Dim SysColor As OLECOLOR
CopyMemory SysColor, Color, Len(SysColor)
If SysColor.Type = &H80 Then
    WinColor = GetSysColor(SysColor.RedOrSys)
Else
    WinColor = Color
End If
End Function

Public Function R(ByVal Color As Long) As Byte ' Get the Red part of a color
CopyMemory R, WinColor(Color), 1
End Function

Public Function G(ByVal Color As Long) As Byte ' Get the Green part of a color
CopyMemory G, ByVal VarPtr(WinColor(Color)) + 1, 1
End Function

Public Function B(ByVal Color As Long) As Byte ' Get the Blue part of a color
CopyMemory B, ByVal VarPtr(WinColor(Color)) + 2, 1
End Function

EDIT: optimized code by putting the WinColor() function before the loop into a var.