Can a userform multipage backcolor be changed?

DRJ

MrExcel MVP
Joined
Feb 17, 2002
Messages
3,853
I have a multipage on a userform and wanted to change the back color. I can change this color fin for buttons and the userform itself, but I don't see the option in the properties for a multipage. And I didn't see it as an available command from vba. Am I missing something here??
 
Hi Tom.

Digging out this old thread again :)

I seem to have managed to find a cleaner and easier solution to this age-old problem of not being able to set the background color of pages in a MultiPage Control.

Here is a Workbook Example.

Code in a Standard Module :

Code:
'*******************************
' // This code Sets the BackColor of
' // Pages on a Multipage Control.(Excel)
'*******************************
Option Explicit
 
'=============================
' // Private Declarations..
'=============================
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
' A BITMAPINFO structure for bitmaps with no color palette.
Private Type BITMAPINFO_NoColors
    bmiHeader As BITMAPINFOHEADER
End Type
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private Type MemoryBitmap
    hdc As Long
    hbm As Long
    oldhDC As Long
    wid As Long
    hgt As Long
    bitmap_info As BITMAPINFO_NoColors
End Type
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) _
As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long
 
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal _
nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO_NoColors, _
ByVal wUsage As Long) _
As Long
 
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
 
Private Declare Function SetBkMode Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nBkMode As Long) _
As Long
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
 
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
 
'=============================
' // Public Routines.
'=============================
Public Sub SetBackColor(Page As MSForms.Page, Color As Long)
 
    Const sBMPFile As String = "C:\Temp.bmp"
    Dim memory_bitmap As MemoryBitmap
 
    ' Create the memory bitmap.
    memory_bitmap = MakeMemoryBitmap _
    (Page)
 
    ' Draw on the bitmap.
    DrawOnMemoryBitmap memory_bitmap, Color
 
    ' Save the bmp.
    Call SaveMemoryBitmap(memory_bitmap, sBMPFile)
 
    ' load the bmp onto the page.
    Set Page.Picture = LoadPicture(sBMPFile)
 
    ' Delete the memory bitmap.
    DeleteMemoryBitmap memory_bitmap
 
    ' Delete BMP file.
    Kill sBMPFile
 
End Sub
 
 
 
'=============================
' // Private Routines.
'=============================
 
' Make a memory bitmap according to the MultiPage size.
Private Function MakeMemoryBitmap _
(Page As MSForms.Page) As MemoryBitmap
 
    Dim result As MemoryBitmap
    Dim bytes_per_scanLine As Long
    Dim pad_per_scanLine As Long
    Dim new_font As Long
 
    ' Create the device context.
    result.hdc = CreateCompatibleDC(0)
 
 
    ' Define the bitmap.
    With result.bitmap_info.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(result.bitmap_info.bmiHeader)
        .biWidth = Page.Parent.Parent.Width 'wid
        .biHeight = Page.Parent.Parent.Height ' hgt
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
        31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
        * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With
 
    ' Create the bitmap.
    result.hbm = CreateDIBSection( _
    result.hdc, result.bitmap_info, _
    DIB_RGB_COLORS, ByVal 0&, _
    ByVal 0&, ByVal 0&)
 
    ' Make the device context use the bitmap.
    result.oldhDC = SelectObject(result.hdc, result.hbm)
 
    ' Return the MemoryBitmap structure.
    result.wid = Page.Parent.Parent.Width
    result.hgt = Page.Parent.Parent.Height
 
    MakeMemoryBitmap = result
 
End Function
 
Private Sub DrawOnMemoryBitmap( _
memory_bitmap As _
MemoryBitmap, Color As Long _
)
 
   Dim LB As LOGBRUSH, tRect As RECT
   Dim hBrush As Long
 
   LB.lbColor = Color
 
   'Create a new brush
    hBrush = CreateBrushIndirect(LB)
    With memory_bitmap
       SetRect tRect, 0, 0, .wid, .hgt
    End With
 
    SetBkMode memory_bitmap.hdc, 2 'Opaque
 
    'Paint the mem dc.
    FillRect memory_bitmap.hdc, tRect, hBrush
 
End Sub
 
' Save the memory bitmap into a bitmap file.
Private Sub SaveMemoryBitmap( _
memory_bitmap As MemoryBitmap, _
ByVal file_name As String _
)
 
    Dim bitmap_file_header As BITMAPFILEHEADER
    Dim fnum As Integer
    Dim pixels() As Byte
 
    ' Fill in the BITMAPFILEHEADER.
    With bitmap_file_header
        .bfType = &H4D42   ' "BM"
        .bfOffBits = Len(bitmap_file_header) + _
        Len(memory_bitmap.bitmap_info.bmiHeader)
        .bfSize = .bfOffBits + _
        memory_bitmap.bitmap_info.bmiHeader.biSizeImage
    End With
 
    ' Open the output bitmap file.
    fnum = FreeFile
    Open file_name For Binary As fnum
    ' Write the BITMAPFILEHEADER.
    Put #fnum, , bitmap_file_header
    ' Write the BITMAPINFOHEADER.
    ' (Note that memory_bitmap.bitmap_info.bmiHeader.biHeight
    ' must be positive for this.)
    Put #fnum, , memory_bitmap.bitmap_info
    ' Get the DIB bits.
    ReDim pixels(1 To 4, _
    1 To memory_bitmap.wid, _
    1 To memory_bitmap.hgt)
    GetDIBits memory_bitmap.hdc, memory_bitmap.hbm, _
    0, memory_bitmap.hgt, pixels(1, 1, 1), _
    memory_bitmap.bitmap_info, DIB_RGB_COLORS
    ' Write the DIB bits.
    Put #fnum, , pixels
    ' Close the file.
    Close fnum
 
End Sub
 
' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap( _
memory_bitmap As MemoryBitmap _
)
 
    SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
    DeleteObject memory_bitmap.hbm
    DeleteDC memory_bitmap.hdc
 
End Sub

And here is how to easily implement the code in the UserForm Module :

Code:
Option Explicit
 
Private Sub UserForm_Initialize()
 
    '// Set the Pages BackColors .
 
    Call SetBackColor(MultiPage1.Pages(0), vbYellow) 'Yellow.
    Call SetBackColor(MultiPage1.Pages(1), RGB(255, 0, 0)) 'Red.
    Call SetBackColor(MultiPage2.Pages(0), vbGreen) 'Green.
    Call SetBackColor(MultiPage2.Pages(1), vbMagenta) 'Purple.
 
End Sub
 
Upvote 0

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Wow Jaafar, thank you very much, this looks really good.

I looked at all the API, but can you please explain to me in English what basically is going on here? Is it bitmap overlay, or a rectangle overlay, or whatever it is that's coloring the multipages. You are scaring me.
 
Upvote 0
Wow Jaafar, thank you very much, this looks really good.

I looked at all the API, but can you please explain to me in English what basically is going on here? Is it bitmap overlay, or a rectangle overlay, or whatever it is that's coloring the multipages. You are scaring me.

Hi Tom - Nice to see you.

Essentially, what the code does is create a BMP in memory big enough to cover the Page area then get the memory BMP DC and draw whatever you want on it (in this case we just filled the memory BMP area with the desired colored brush) then save the BMP to disk as a BMP file so we can load the file as the Page Picture using the usual LoadPicture Function. Once we are done delete the BMP file.

What is neat about this approach is the fact that the whole work is done behind the scenes in memory and setting the BackColor of each Page on each Multipage Control is very easy and intuitive.
 
Upvote 0
Thank you Jaafar. Do you see any potential danger of a workbook or the entire Excel application crashing if a user does....[fill in the blank].

Just wondering how stable this will be and if any particular actions should be avoided due to all the API going on, any concerns?

Do you see any reason for concern if this is used on operating systems for Vista or Windows7.

Thanks again Jaafar, very nice.
 
Upvote 0
Although the code uses lots of API functions, it should be stable and shouldn't crash the application should an error occur. The problem of code instability occurs mainly when using SubClassing/Hooking techniques which is not the case here.

I have only tested this on Win XP Excel 2003 so I don't know how/if it works on other platforms.

By the way, the above code has a minor problem : If the MultiPage Control is too wide or too tall, the Pages are not fully colored.

This is due to the fact that when creating the memory BMP, I mistakenly set the Width and Height in Points and not in Pixels . I have corrected that in the following code :

WorkBook Example ( with wide Multipage)

Main Code :
Code:
'*******************************
' // This code Sets the BackColor of
' // Pages on a Multipage Control.(Excel)
'*******************************
Option Explicit
 
'=============================
' // Private Declarations..
'=============================
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type BITMAPINFOHEADER '40 bytes
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type
 
' A BITMAPINFO structure for bitmaps with no color palette.
Private Type BITMAPINFO_NoColors
    bmiHeader As BITMAPINFOHEADER
End Type
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private Type MemoryBitmap
    hdc As Long
    hbm As Long
    oldhDC As Long
    wid As Long
    hgt As Long
    bitmap_info As BITMAPINFO_NoColors
End Type
 
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) _
As Long
 
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) _
As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long
 
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long
 
Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal _
nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO_NoColors, _
ByVal wUsage As Long) _
As Long
 
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
 
Private Declare Function SetBkMode Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nBkMode As Long) _
As Long
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Private Declare Function FillRect Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
 
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72
 
'=============================
' // Public Routines.
'=============================
Public Sub SetBackColor(Page As MSForms.Page, Color As Long)
 
    Const sBMPFile As String = "C:\Temp.bmp"
    Dim memory_bitmap As MemoryBitmap
 
    ' Create the memory bitmap.
    memory_bitmap = MakeMemoryBitmap _
    (Page)
 
    ' Draw on the bitmap.
    DrawOnMemoryBitmap memory_bitmap, Color
 
    ' Save the bmp.
    Call SaveMemoryBitmap(memory_bitmap, sBMPFile)
 
    ' load the bmp onto the page.
    Set Page.Picture = LoadPicture(sBMPFile)
 
    ' Delete the memory bitmap.
    DeleteMemoryBitmap memory_bitmap
 
    ' Delete BMP file.
    Kill sBMPFile
 
End Sub
 
 
 
'=============================
' // Private Routines.
'=============================
 
' Make a memory bitmap according to the MultiPage size.
Private Function MakeMemoryBitmap _
(Page As MSForms.Page) As MemoryBitmap
 
    Dim result As MemoryBitmap
    Dim bytes_per_scanLine As Long
    Dim pad_per_scanLine As Long
    Dim new_font As Long
 
    ' Create the device context.
    result.hdc = CreateCompatibleDC(0)
 
 
    ' Define the bitmap.
    With result.bitmap_info.bmiHeader
        .biBitCount = 32
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(result.bitmap_info.bmiHeader)
        .biWidth = PTtoPX(Page.Parent.Parent.InsideWidth, 0)
        .biHeight = PTtoPX(Page.Parent.Parent.InsideHeight, 1)
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
        31) \ 32) * 4)
        pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
        * .biBitCount) + 7) \ 8)
        .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
    End With
 
    ' Create the bitmap.
    result.hbm = CreateDIBSection( _
    result.hdc, result.bitmap_info, _
    DIB_RGB_COLORS, ByVal 0&, _
    ByVal 0&, ByVal 0&)
 
    ' Make the device context use the bitmap.
    result.oldhDC = SelectObject(result.hdc, result.hbm)
 
    ' Return the MemoryBitmap structure.
    result.wid = PTtoPX(Page.Parent.Parent.InsideWidth, 0)
    result.hgt = PTtoPX(Page.Parent.Parent.InsideHeight, 1)
 
    MakeMemoryBitmap = result
 
End Function
 
Private Sub DrawOnMemoryBitmap( _
memory_bitmap As _
MemoryBitmap, Color As Long _
)
 
   Dim LB As LOGBRUSH, tRect As RECT
   Dim hBrush As Long
 
   LB.lbColor = Color
 
   'Create a new brush
    hBrush = CreateBrushIndirect(LB)
    With memory_bitmap
       SetRect tRect, 0, 0, .wid, .hgt
    End With
 
    SetBkMode memory_bitmap.hdc, 2 'Opaque
 
    'Paint the mem dc.
    FillRect memory_bitmap.hdc, tRect, hBrush
 
End Sub
 
' Save the memory bitmap into a bitmap file.
Private Sub SaveMemoryBitmap( _
memory_bitmap As MemoryBitmap, _
ByVal file_name As String _
)
 
    Dim bitmap_file_header As BITMAPFILEHEADER
    Dim fnum As Integer
    Dim pixels() As Byte
 
    ' Fill in the BITMAPFILEHEADER.
    With bitmap_file_header
        .bfType = &H4D42   ' "BM"
        .bfOffBits = Len(bitmap_file_header) + _
        Len(memory_bitmap.bitmap_info.bmiHeader)
        .bfSize = .bfOffBits + _
        memory_bitmap.bitmap_info.bmiHeader.biSizeImage
    End With
 
    ' Open the output bitmap file.
    fnum = FreeFile
    Open file_name For Binary As fnum
    ' Write the BITMAPFILEHEADER.
    Put #fnum, , bitmap_file_header
    ' Write the BITMAPINFOHEADER.
    ' (Note that memory_bitmap.bitmap_info.bmiHeader.biHeight
    ' must be positive for this.)
    Put #fnum, , memory_bitmap.bitmap_info
    ' Get the DIB bits.
    ReDim pixels(1 To 4, _
    1 To memory_bitmap.wid, _
    1 To memory_bitmap.hgt)
    GetDIBits memory_bitmap.hdc, memory_bitmap.hbm, _
    0, memory_bitmap.hgt, pixels(1, 1, 1), _
    memory_bitmap.bitmap_info, DIB_RGB_COLORS
    ' Write the DIB bits.
    Put #fnum, , pixels
    ' Close the file.
    Close fnum
 
End Sub
 
' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap( _
memory_bitmap As MemoryBitmap _
)
 
    SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
    DeleteObject memory_bitmap.hbm
    DeleteDC memory_bitmap.hdc
 
End Sub
 
Private Function ScreenDPI(bVert As Boolean) As Long
 
    Static lDPI(1), lDC
 
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
 
    ScreenDPI = lDPI(Abs(bVert))
 
End Function
 
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
 
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
 
End Function
 
Upvote 0
Thank you Jaafar. Also bumping this up to the top becuase it's cool and I hope others download the example and see how nice this looks. Great stuff.
 
Upvote 0
Hello Jaafar and Tom,

This is exactly what I'm looking for, thanks for doing all the hard work Jaafar!

Just to expand on it a bit, I was looking to use a system color (ActiveBorder) as the background for my multipage userform and I quickly found that H8000000A wasn't a valid entry. With a bit of googleing, I found this post which showed how to convert the system colors in to RGB.

First I added in this code to a module:

Code:
Public Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Then added a button on a blank userform and attached this code to the click event:

Code:
MsgBox Hex(GetSysColor(10))

The 10 comes from the decimal conversion of the last two characters on the system color. So for instance if you'd like to know the RGB of ActiveBorder ,H8000000A, you'd put in 10 (you actually get the number by converting the last two characters from HEX to DEC...I used the built in Windows Calculator set to Programmer, but any HEX to DEC conversion would work).

So after putting in the desired decimal number, press the button on your userform and you end up with a message box that gives you the RGB equivalent to what you're looking for, in this case B4B4B4. Fire up the HEX converter and change B4 to a DEC and you get 180,180,180. Now all you need to do is chance the part of the code that Jaafar gave us that paints the multipage to:

Code:
Call SetBackColor(MultiPage1.Pages(0), RGB(180, 180, 180))

and you now have a multipage background that matches the ActiveBorder color.

As pointed out in the link I posted above, the RGB HEX actually comes out of the system as BGR, so when putting in your numbers to adjust the colors make sure you put them in reverse order (as an example, try the 'Highlight' system color (DEC 13) and put the codes in first as it comes out of the system (255,153,51) and then in reverse order (51,153,255)).

Hope that helps!
 
Upvote 0
Nice addition sous2817 .

I've had the same Color values conversion problem before .

Thanks for passing this important info.
 
Upvote 0
One possible work around I've tried is to draw a frame control over the page area. The frame background can then be set to any available color. While not perfect (the tab area is not covered) it can add some aesthetics to the form, without too much bloating. Make sure to blank out the frame caption.
 
Upvote 0
Exactly ..... Isn't using a simple Frame control the easiest solution? In that case, you also have the option of using background images ... basically, you can do whatever you want by using Frames.

Seems much simpler than all this bitmap mumbo jumbo. No offense, guys.

Thanks for the interesting workarounds, though.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,208
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top