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
Here is a much simpler API-based method which should also work with scrollable multipages.

Code in the UserForm Module :

Code: 
Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    #Else
        Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    #End If
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe 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 hdc As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr, hBrush As LongPtr, hCopy As LongPtr, ar() As LongPtr
#Else
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush 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 OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private hdc As Long, hMemDc As Long, hMemBmp As Long, hBrush As Long, hCopy As Long, ar() As Long
#End If

Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const S_OK = 0

Private Sub UserForm_Initialize()
 
   [COLOR=#008000][B] '// Set the Pages BackColors .[/B][/COLOR]
 
    Call SetBackColor(Page:=MultiPage1.Pages(0), BackColor:=vbRed)
    Call SetBackColor(Page:=MultiPage1.Pages(1), BackColor:=RGB(20, 200, 100))
 
End Sub

Private Sub UserForm_Terminate()
    Call DeleteResources
End Sub


Private Sub SetBackColor(Page As MSForms.Page, BackColor As Long)

    Dim R As RECT
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Static i As Integer
    
    hdc = GetDC(0)
    SetRect R, 0, 0, 1, 1

    With R
        hMemBmp = CreateCompatibleBitmap(hdc, .Right - .Left, .Bottom - .Top)
    End With

    hMemDc = CreateCompatibleDC(hdc)
    DeleteObject SelectObject(hMemDc, hMemBmp)
    hBrush = CreateSolidBrush(BackColor)
    FillRect hMemDc, R, hBrush
    hCopy = CopyImage(hMemBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
  
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0
    End With

    Page.PictureSizeMode = fmPictureSizeModeStretch
    If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic) = S_OK Then
        Set Page.Picture = IPic
    Else
        MsgBox "Unable to create Picture", vbCritical, "Error."
    End If

    DeleteObject hMemBmp
    DeleteObject hMemDc
    DeleteObject hBrush
    ReleaseDC 0, hdc

    ReDim Preserve ar(i)
    ar(i) = hCopy
    i = i + 1

End Sub

Private Sub DeleteResources()

    Dim element As Variant
    
    For Each element In ar
        DeleteObject element
    Next

End Sub
 
Last edited:
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Thanks Jaafar, this works for me. Only thing is that I moved the code outside of the userform and into a normal module because I want to use the code for more than 1 form.
 
Upvote 0
AS you said, thank goodness for search engines. So I copied the last submission of this, I assume Microsoft hasn't changed, and I get a "compile error: Wrong number or invalid property assignment" Now I'm teaching myself VBA through examples and Youtube and have no idea about any of this here " " I notice that it keeps changing my to lowercase., but I admit I'm lost on this one
 
Upvote 0
The OleCreatePictureIndirect API is the one causing the issue as there are two versions depending on the Windows install namely one in the oleAut32.dll and the other (older) in the olepro32.dll

Workbook Demo

Anyway, here is an update that should work accross all versions:

In the UserForm Module with MultiPage1

VBA Code: 
Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
       hPic As Long
       hPal As Long
    #End If
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe 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 hdc As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr, hBrush As LongPtr, hCopy As LongPtr, ar() As LongPtr
  
#Else
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush 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 hdc As Long, hMemDc As Long, hMemBmp As Long, hBrush As Long, hCopy As Long, ar() As Long
  
#End If


Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const S_OK = 0




Private Sub UserForm_Initialize()

   '// Set the Pages BackColors

    Call SetBackColor(Page:=MultiPage1.Pages(0), BackColor:=vbRed)
    Call SetBackColor(Page:=MultiPage1.Pages(1), BackColor:=RGB(20, 200, 100))

End Sub

Private Sub UserForm_Terminate()
    Call DeleteResources
End Sub




Private Sub SetBackColor(Page As MSForms.Page, BackColor As Long)

    #If VBA7 Then
        Dim hLib As LongPtr
    #Else
        Dim hLib As Long
    #End If

    Dim R As RECT
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim iPic As IPicture
    Dim lRet As Long
    Static i As Integer
  

    Page.PictureSizeMode = fmPictureSizeModeStretch
  
    hdc = GetDC(0)
    SetRect R, 0, 0, 1, 1

    With R
        hMemBmp = CreateCompatibleBitmap(hdc, .Right - .Left, .Bottom - .Top)
    End With

    hMemDc = CreateCompatibleDC(hdc)
    DeleteObject SelectObject(hMemDc, hMemBmp)
    hBrush = CreateSolidBrush(BackColor)
    FillRect hMemDc, R, hBrush
    hCopy = CopyImage(hMemBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0
    End With
  
    hLib = LoadLibrary("oleAut32.dll")
        If hLib Then
            lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
        Else
            hLib = LoadLibrary("olepro32.dll")
            lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
        End If
    FreeLibrary hLib
  
    If lRet = S_OK Then
        Set Page.Picture = iPic
    Else
        MsgBox "Unable to create Picture", vbCritical, "Error."
    End If

    DeleteObject hMemBmp
    DeleteObject hMemDc
    DeleteObject hBrush
    ReleaseDC 0, hdc

    ReDim Preserve ar(i)
    ar(i) = hCopy
    i = i + 1

End Sub

Private Sub DeleteResources()

    Dim element As Variant
  
    For Each element In ar
        DeleteObject element
    Next

End Sub
 
Upvote 0
Nice, but like mentioned by others here. Frame is nicer and it's helpful when you put the name of the tab as Caption. So you see on which page you are.
It would have been nice if the tabs get color when you click on it.
But I liked it, so learned little bit more. :)
 
Upvote 0
mucuracat said:
To see which tab page you are, I found this.
stackoverflow.com

Changing the colour of tabs of Multipage in VBA

I'm using the Forms in VBA and I was wondering if it is possible to make the tabs in my Multipages change colour when active, so that there is a better contrast with the other tabs. Here is a scree...
stackoverflow.com stackoverflow.com
Click to expand...
Hi mucuracat,

Did you see this ?
www.mrexcel.com

Changing the Font & Back Colors of individual Tabs\Pages in a MultiPage

Hi dear forum, As you know, the MsForms Multipage control doesn't offer a built-in functionality for changing the colors of individual tabs. I have seen many requests for this functionality over the years and the usual workaround has always been to add some helper buttons\labels , to change the...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
88
6StringJazzer
6StringJazzer
H
  • Question Question
Userform Help
Replies
5
Views
341
Hjemmet
H
T
  • Question Question
Refer to a sheet selected by combobox
Replies
2
Views
378
dmt32
D
P
  • Solved
Userform - Only allow one OptionButton to be selected inside multipage within a Frame with other OptionButtons
Replies
7
Views
1K
PioSwgr
P
P
  • Question Question
Command Buttons on Userform
Replies
5
Views
505
PaulWJ
P

Forum statistics

Threads
1,223,904
Messages
6,175,295
Members
452,633
Latest member
DougMo

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