PictureBox Mask Color

Hello,

this functions will mask a picturebox.
It's similar of a transparent picture, but here the picture will not get masked ; it's just the picturebox. but at the end it look likes the picture is transparent.

Example application usage:
If you use the graphical command button (http://www.vbforums.com/showthread.php?t=323449) and you have the visual styles activated (e.g. XP themes). The problem is that the backcolor of the themed command button differs still from the system backcolor (vbButtonFace). So it' doesnt matter if the picture is transparent you will have still the backcolor of the picturebox on the themed command button and that looks not nice.
So one way to solve this is by masking the picturebox.

Example function usage:

Code:

---

Call PictureBoxMasking(Picture1, Picture1.BackColor)
Call PictureBoxMasking(Picture1, RGB(255, 255, 255))

---

This example will mask the picturebox itself (backcolor) and the white color of the picture.

Function:

Code:

---

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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function GetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long) As Long
Private Const RGN_OR = 2, RGN_XOR = 3

Public Sub PictureBoxMasking(ByVal PictureBox As VB.PictureBox, ByVal MaskColor As Long)
Dim Skin As Long, TempSkin As Long
Dim Width As Long, Height As Long, ScaleWidth As Long, ScaleHeight As Long
Dim X As Long, Y As Long, OffsetX As Long, OffsetY As Long
Dim WinMaskColor As Long, MemAutoRedraw As Boolean
WinMaskColor = WinColor(MaskColor)
With PictureBox
MemAutoRedraw = .AutoRedraw
.AutoRedraw = True
Select Case .ScaleMode
    Case vbTwips
        Width = .Width / Screen.TwipsPerPixelX
        Height = .Height / Screen.TwipsPerPixelY
        ScaleWidth = .ScaleWidth / Screen.TwipsPerPixelX
        ScaleHeight = .ScaleHeight / Screen.TwipsPerPixelY
    Case vbPixels
        Width = .Width
        Height = .Height
        ScaleWidth = .ScaleWidth
        ScaleHeight = .ScaleHeight
    Case Else
        Err.Raise Number:=1, Description:="ScaleMode not set to twips or pixels"
End Select
OffsetX = (Width - ScaleWidth) / 2
OffsetY = (Height - ScaleHeight) / 2
For X = 0 To ScaleWidth - 1
    For Y = 0 To ScaleHeight - 1
        If GetPixel(.hDC, X, Y) <> WinMaskColor Then
            If Skin <> 0 Then
                TempSkin = CreateRectRgn(X + OffsetX, Y + OffsetY, X + OffsetX + 1, Y + OffsetY + 1)
                CombineRgn Skin, Skin, TempSkin, RGN_OR
                DeleteObject TempSkin
            Else
                Skin = CreateRectRgn(X + OffsetX, Y + OffsetY, X + OffsetX + 1, Y + OffsetY + 1)
            End If
        End If
    Next Y
Next X
If .BorderStyle <> 0 Then
    For X = 0 To Width - 1
        For Y = 0 To Height - 1
            If X < OffsetX Or Y < OffsetY Or X + OffsetX > Width - 1 Or Y + OffsetY > Height - 1 Then
                If Skin <> 0 Then
                    TempSkin = CreateRectRgn(X, Y, X + 1, Y + 1)
                    CombineRgn Skin, Skin, TempSkin, RGN_OR
                    DeleteObject TempSkin
                Else
                    Skin = CreateRectRgn(X, Y, X + 1, Y + 1)
                End If
            End If
        Next Y
    Next X
End If
.AutoRedraw = MemAutoRedraw
If GetWindowRgn(.hWnd, CreateRectRgn(0, 0, 0, 0)) <> 0 Then
    TempSkin = CreateRectRgn(0, 0, 0, 0)
    GetWindowRgn .hWnd, TempSkin
    CombineRgn Skin, Skin, TempSkin, RGN_XOR
    TempSkin = CreateRectRgn(0, 0, Width, Height)
    CombineRgn Skin, Skin, TempSkin, RGN_XOR
    DeleteObject TempSkin
End If
SetWindowRgn .hWnd, Skin, True
DeleteObject Skin
End With
End Sub

Public Sub PictureBoxClearMasking(ByVal PictureBox As VB.PictureBox)
Dim Skin As Long
Dim Width As Long, Height As Long
With PictureBox
Select Case .ScaleMode
    Case vbTwips
        Width = .Width / Screen.TwipsPerPixelX
        Height = .Height / Screen.TwipsPerPixelY
    Case vbPixels
        Width = .Width
        Height = .Height
    Case Else
        Err.Raise Number:=1, Description:="ScaleMode not set to twips or pixels"
End Select
Skin = CreateRectRgn(0, 0, Width, Height)
SetWindowRgn .hWnd, Skin, True
DeleteObject Skin
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

---

The function PictureBoxClearMasking is needed after you change the borderstyle at runtime, but then you need to re-mask everything:

Code:

---

Picture1.BorderStyle = 0 ' Change to nonborder
Call PictureBoxClearMasking(Picture1)

---

I have 2 suggestions: move the WinColor(MaskColor) function call outside of the loop. Cache its return value in a temp var and use that inside the loop. Also, optimizing the If..Else block by putting the more likely statement(s) right after Then might help speed up the loops. The 2 loops are very CPU intensive! :afrog: