Can a userform multipage backcolor be changed?

DRJ

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??
 
Sort by date Sort by votes
bloodymurderlive said:
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.
Click to expand...

Hello and welcome to the board!

I'm sure none is taken, and your solution was also suggested in the 2nd post. While it may seem to be the easiest solution, it also didn't seem to meet the OP's needs / expectations.

That being said, my experience is that Jaafar Tribak doesn't really concern himself with the easiest solution but more of the "can it be done" solution, in which case he proved that it can be. Feel free to do a search for other posts done by Jaarfar Tribak and see what else he's come up with.
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
That being said, my experience is that Jaafar Tribak doesn't really concern himself with the easiest solution but more of the "can it be done" solution, in which case he proved that it can be. Feel free to do a search for other posts done by Jaarfar Tribak and see what else he's come up with.
Click to expand...

Jaafar is the king of "can it be done" solutions. I often wonder if Microsoft peruses these sites to see what kind of stuff people like Jaafar come up with!
 
Upvote 0
bloodymurderlive said:
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.
Click to expand...


No offense taken

I just thought painting each Page without the need to add an addintional frame layer to the Multipage control was much cleaner and fun to do.
Being able to paint each Page tab area as well would certainly be a nice touch but although I feel this can be done it will take rather involved coding.
 
Upvote 0
YES, color the tabs ... now THAT would be something, for sure.

Let me know if you ever do anything with that. I don't have the know-how, myself.
 
Upvote 0
Hi Jaafar,

This is a great piece of code, which works really well for Excel 2010 32-bit. Can you explain what changes would be required to allow your code to work on Excel 2010 64-bit? I have researched and it appears that the declare statements need to be modified to include a "PtrSafe" component, but I am not familiar enough with API calls to make this change. Can you help?
 
Upvote 0
bloodymurderlive said:
YES, color the tabs ... now THAT would be something, for sure.

Let me know if you ever do anything with that. I don't have the know-how, myself.
Click to expand...

Hi,
Whilst not being able to colour the tabs, what I found from an aesthetics point of view is that if I change the tab style to "buttons", then at least they look like command buttons and have the same colours as other command buttons on my user form.
 
Upvote 0
Jaafar Tribak said:
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
Click to expand...

I put the first code in a standard module, then I put the second code behind my UserForm4 which has Multi-Page's. I get an error that says variable not defined? Am I supposed to change something for the second part of the code for the form? Thanks.
 
Upvote 0
Jaafar Tribak said:
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 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum]#fnum[/URL] , , bitmap_file_header
    ' Write the BITMAPINFOHEADER.
    ' (Note that memory_bitmap.bitmap_info.bmiHeader.biHeight
    ' must be positive for this.)
    Put [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum]#fnum[/URL] , , 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 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fnum]#fnum[/URL] , , 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
Click to expand...


Thanks for this solution. This worked great for me.... except now I want to make one of my multipages scrollable. How do I change the code to get all of the scrollable area this set color? At the moment, when I scroll, the originally unseen part of the scroll area remains the unchanged color.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Refer to a sheet selected by combobox
Replies
2
Views
69
dmt32
D
P
  • Solved
Userform - Only allow one OptionButton to be selected inside multipage within a Frame with other OptionButtons
Replies
7
Views
421
PioSwgr
P
P
  • Question
Command Buttons on Userform
Replies
5
Views
166
PaulWJ
P
U
  • Solved
VBA Userform - Multipage does not keep memory in Page2
Replies
1
Views
483
urubag
U
A
  • Solved
VBA Userform: Multipage Control Value Change
Replies
1
Views
626
AFPathfinder
A

Forum statistics

Threads
1,214,430
Messages
6,119,438
Members
448,897
Latest member
dukenia71

Share this page

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