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

[Jaafar Tribak]

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 tabs style to fmTabStyleButtons or to dynamically change the tab caption text of the currently active tab.

Here, I am resorting to a more radical approach which consists of handling the WM_PAINT message and doing our custom drawing of choice from scratch.

In order to change the font and\or Back color of a given individual tab, all we need to do is call the following routine :

Sub PaintTab( _
    ByVal Page As Object, _
    Optional ByVal Paint As Boolean, _
    Optional ByVal FontColor As Variant, _
    Optional ByVal BackColor As Variant, _
    Optional ByVal ExtendTabColorToWholePage As Boolean, _
    Optional ByVal TabShape As eTabShape = Flat)

The arguments are self-explanatory. The last eTabShape argument offers 3 different possible shapes for the Tabs, namely Flat = 0 , Bumped = 1 and Trapezoid = 2.

Issues:
Due to the fact that the code subclasses the userform, this method will only work in Modal UserForms... Also, careful error handling in any other existing code is advised (Actually, automatic error handling is actually built-in in the "SafeExit routine", but still, propper defensive error handling is recommended when using this code just in case)

Demo workbook: MultiPageTabPainting.xls








1-API code in a Standard Module:

Option Explicit

Public Enum eTabShape
    Flat = 0
    Bumped = 1
    Trapezoid = 2
End Enum

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Private Type POINTF
   x As Single
   Y As Single
End Type

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

Private Type PAINTSTRUCT
    #If Win64 Then
        hdc As LongLong
    #Else
        hdc As Long
    #End If
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) As Byte
End Type

Private Type uPicDesc
    size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #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

Private Type LOGPEN
    lopnStyle As Long
    lopnWidth As POINTAPI
    lopnColor As Long
End Type

Private Type CWPSTRUCT
    #If Win64 Then
        lParam As LongLong
        wParam As LongLong
        message As Long
        hwnd As LongLong
    #Else
        lParam As Long
        wParam As Long
        message As Long
        hwnd As Long
    #End If
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
  #If Win64 Then
        DebugEventCallback As LongLong
        SuppressBackgroundThread As LongLong
  #Else
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
  #End If
   SuppressExternalCodecs As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)
    Private Declare PtrSafe Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
    Private Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
    Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) 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 Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function FloodFill Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (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 RedrawWindow Lib "user32" (ByVal hwnd As LongPtr, lprcUpdate As RECT, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
    Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
    Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As LongPtr, hGraphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As LongPtr, ByVal SmoothingMd As Long) As Long
    Private Declare PtrSafe Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, pen As LongPtr) As Long
    Private Declare PtrSafe Function GdipSetPenColor Lib "gdiplus" (ByVal pen As LongPtr, ByVal argb As Long) As Long
    Private Declare PtrSafe Function GdipSetPenWidth Lib "gdiplus" (ByVal pen As LongPtr, ByVal Width As Single) As Long
    Private Declare PtrSafe Function GdipSetPenDashStyle Lib "gdiplus" (ByVal pen As LongPtr, ByVal dStyle As Long) As Long
    Private Declare PtrSafe Function GdipDrawLine Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single) As Long
    Private Declare PtrSafe Function GdipDrawRectangle Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, ByVal x As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As Long
    Private Declare PtrSafe Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, brush As LongPtr) As Long
    Private Declare PtrSafe Function GdipDrawPolygon Lib "gdiplus" (ByVal graphics As LongPtr, ByVal pen As LongPtr, Points As POINTF, ByVal count As Long) As Long
    Private Declare PtrSafe Function GdipFillPolygon Lib "gdiplus" (ByVal graphics As LongPtr, ByVal brush As LongPtr, Points As POINTF, ByVal count As Long, ByVal FillMd As Long) As Long
    Private Declare PtrSafe Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteBrush Lib "gdiplus" (ByVal brush As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeletePen Lib "gdiplus" (ByVal pen As LongPtr) As Long
  
    Private hHook As LongPtr
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub ZeroMemory Lib "KERNEL32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long)
    Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
    Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) 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 CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long
    Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex 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 SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor 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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, 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 DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
    Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
    Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (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 RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex 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 FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function GetFocus Lib "user32" () As Long
    Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
    Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, hGraphics As Long) As Long
    Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal graphics As Long, ByVal SmoothingMd As Long) As Long
    Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, pen As Long) As Long
    Private Declare Function GdipSetPenColor Lib "gdiplus" (ByVal pen As Long, ByVal argb As Long) As Long
    Private Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal pen As Long, ByVal Width As Single) As Long
    Private Declare Function GdipSetPenDashStyle Lib "gdiplus" (ByVal pen As Long, ByVal dStyle As Long) As Long
    Private Declare Function GdipDrawLine Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal x1 As Single, ByVal y1 As Single, ByVal x2 As Single, ByVal y2 As Single) As Long
    Private Declare Function GdipDrawRectangle Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As Long
    Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, brush As Long) As Long
    Private Declare Function GdipDrawPolygon Lib "gdiplus" (ByVal graphics As Long, ByVal pen As Long, Points As POINTF, ByVal count As Long) As Long
    Private Declare Function GdipFillPolygon Lib "gdiplus" (ByVal graphics As Long, ByVal brush As Long, Points As POINTF, ByVal count As Long, ByVal FillMd As Long) As Long
    Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As Long) As Long
    Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal brush As Long) As Long
    Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal pen As Long) As Long
  
    Private hHook As Long
#End If
  


Public Sub PaintTab( _
    ByVal Page As Object, _
    Optional ByVal Paint As Boolean, _
    Optional ByVal FontColor As Variant, _
    Optional ByVal BackColor As Variant, _
    Optional ByVal ExtendTabColorToWholePage As Boolean, _
    Optional ByVal TabShape As eTabShape = Flat)

    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If
  
    Const WH_CALLWNDPROC = 4

    Dim oMultiPage As Control
  
    Set oMultiPage = Page.Parent
    hwnd = oMultiPage.[_GethWnd]
  
    If IsMissing(FontColor) Then FontColor = 0
    If IsMissing(BackColor) Then
        BackColor = oMultiPage.BackColor
        Call TranslateColor(oMultiPage.BackColor, 0, BackColor)
    End If

    Page.Tag = FontColor & "||" & BackColor & "||" & ExtendTabColorToWholePage & "||" & TabShape & "||" & Paint
  
    If GetProp(hwnd, "MultiPageSubclassed") = 0 Then
        If hHook = 0 Then
            hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf SafeSubclassingHookFunction, _
            GetModuleHandle(vbNullString), GetWindowThreadProcessId(Application.hwnd, 0))
        End If
        Call SetProp(hwnd, "MultiPageSubclassed", 1)
        Call SetWindowSubclass(hwnd, AddressOf WndProc, ObjPtr(oMultiPage), 0)
    End If
  
End Sub



'_______________________________PRIVATE ROUTINES__________________________________________

#If Win64 Then
    Private Function WndProc( _
            ByVal hwnd As LongLong, _
            ByVal wMsg As Long, _
            ByVal wParam As LongLong, _
            ByVal lParam As LongLong, _
            ByVal uIdSubclass As Object, _
            ByVal This As LongLong) As LongLong
#Else
    Private Function WndProc( _
            ByVal hwnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByVal uIdSubclass As Object, _
            ByVal This As Long) As Long
#End If

    Const WM_DESTROY = &H2
    Const WM_PAINT As Long = &HF&
    Const RDW_INVALIDATE = &H1
  
    Static oPrevPage As Object
    Static tPrevTabRect As RECT
  
    Dim tPS As PAINTSTRUCT, tTabRect As RECT, tCurTabRect As RECT
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim oPage As Object

    Select Case wMsg
  
        Case WM_PAINT
            Call BeginPaint(hwnd, tPS)
            Call DrawMultiPageBackGround(uIdSubclass)
            For Each oPage In uIdSubclass.Pages
                tTabRect = GetPageRect(oPage, hwnd)
                If oPage Is uIdSubclass.SelectedItem Then
                    If Not oPrevPage Is Nothing Then
                        If Not oPrevPage Is uIdSubclass.SelectedItem Then
                            With tPrevTabRect
                                p1.x = .Left: p1.Y = .Top - 10
                                p2.x = .Right: p2.Y = .Bottom
                            End With
                            Call ScreenToClient(GetParent(hwnd), p1)
                            Call ScreenToClient(GetParent(hwnd), p2)
                            With tPrevTabRect
                                .Left = p1.x:     .Top = p1.Y
                                .Right = p2.x: .Bottom = p2.Y
                            End With
                            Call RedrawWindow(GetParent(hwnd), tPrevTabRect, 0, RDW_INVALIDATE)
                        End If
                    End If
                    Set oPrevPage = uIdSubclass.SelectedItem
                    tPrevTabRect = tTabRect
                    tCurTabRect = tTabRect
                End If

                If Len(oPage.Tag) Then
                    Call DrawTab(True, hwnd, oPage, VarPtr(tTabRect))
                    If oPage Is uIdSubclass.SelectedItem Then
                        Call DrawPageOutline(True, hwnd, oPage, VarPtr(tCurTabRect))
                    End If
                Else
                    Call DrawTab(False, hwnd, oPage, VarPtr(tTabRect))
                    If oPage Is uIdSubclass.SelectedItem Then
                        Call DrawPageOutline(False, hwnd, oPage, VarPtr(tCurTabRect))
                    End If
                End If
              
            Next oPage
            Call EndPaint(hwnd, tPS)
          
        Case WM_DESTROY
            Call UnhookWindowsHookEx(hHook)
            hHook = 0
            Call RemoveWindowSubclass(hwnd, WinProcAddr, ObjPtr(uIdSubclass))
            Call RemoveProp(hwnd, "MultiPageSubclassed")
          
    End Select
  
    WndProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)

End Function


Private Sub DrawMultiPageBackGround(ByVal MultiPage As Object)

    #If Win64 Then
        Dim hwnd As LongLong
        Dim hdc As LongLong, hMemDC As LongLong, hMemBmp As LongLong, hOldBmp As LongLong
        Dim hBrush As LongLong, OldBrush As LongLong, hRegion As LongLong
    #Else
        Dim hwnd As Long
        Dim hdc As Long, hMemDC As Long, hMemBmp As Long, hOldBmp As Long
        Dim hBrush As Long, OldBrush As Long, hRegion As Long
    #End If

    Const SRCCOPY = &HCC0020
  
    Dim oMultiPage As Control
    Dim tWinRect As RECT
    Dim lWidth As Long, lHeight As Long, lBackColor As Long
  
  
    Set oMultiPage = MultiPage
    hwnd = oMultiPage.[_GethWnd]
    Call GetWindowRect(hwnd, tWinRect)
  
    lWidth = tWinRect.Right - tWinRect.Left
    lHeight = tWinRect.Bottom - tWinRect.Top
  
    hdc = GetDC(hwnd)
    hMemDC = CreateCompatibleDC(hdc)
    hMemBmp = CreateCompatibleBitmap(hdc, lWidth, lHeight)
    hOldBmp = SelectObject(hMemDC, hMemBmp)
    Call TranslateColor(MultiPage.BackColor, 0, lBackColor)
    hBrush = CreateSolidBrush(lBackColor)
    hRegion = CreateRectRgn(0, 0, lWidth, lHeight)
    OldBrush = SelectObject(hMemDC, hBrush)
    Call FillRgn(hMemDC, hRegion, hBrush)
    Call BitBlt(hdc, 0, 0, lWidth, lHeight, hMemDC, 0, 0, SRCCOPY)
  
    Call SelectObject(hMemDC, hOldBmp)
    Call SelectObject(hMemDC, OldBrush)
  
    Call DeleteDC(hMemDC)
    Call DeleteDC(hMemBmp)
    Call DeleteObject(hBrush)
    Call DeleteObject(hRegion)
    Call ReleaseDC(hwnd, hdc)

End Sub


#If Win64 Then
    Private Sub DrawTab(ByVal IsTagged As Boolean, ByVal hwnd As LongLong, ByVal Page As Object, ByVal pRect As LongLong)
        Dim hdc As LongLong, hMemDC As LongLong, hMemBmp As LongLong, hRegion As LongLong
        Dim OldBrush As LongLong, hOldBmp As LongLong
        Dim hBrush As LongLong, hFont As LongLong
        Dim hPrevFont As LongLong
        Dim hPen As LongLong, hOldPen As LongLong
        Dim hGraphics As LongLong
#Else
    Private Sub DrawTab(ByVal IsTagged As Boolean, ByVal hwnd As Long, ByVal Page As Object, ByVal pRect As Long)
        Dim hdc As Long, hMemDC As Long, hMemBmp As Long, hRegion As Long
        Dim OldBrush As Long, hOldBmp As Long
        Dim hBrush As Long, hFont As Long
        Dim hPrevFont As Long
        Dim hPen As Long, hOldPen As Long
        Dim hGraphics As Long
#End If

    Const TRANSPARENT = 1
    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const DT_LEFT = &H0
    Const SRCCOPY = &HCC0020
    Const DEFAULT_GUI_FONT = 17
    Const S_OK = 0&
    Const UnitPixel = 2
    Const SmoothingModeAntiAlias As Long = &H4
    Const DashStyleSolid = 0

    Dim tTabRect As RECT, tTextRect As RECT, tPoly(1 To 3) As POINTF
    Dim p1 As POINTAPI, p2 As POINTAPI, tpt As POINTAPI, tPen As LOGPEN
    Dim TagArray As Variant
    Dim sCaption As String
    Dim lFontColor As Long
    Dim lBackColor As Long
    Dim bExtendTabColToPage As Boolean
    Dim bPaint As Boolean
    Dim lTabShape As Long
    Dim lPenColor As Long, lRealColor As Long
    Dim lWidth As Long, lHeight As Long
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lToken As Long
  

    sCaption = Replace(Page.Caption, Page.Accelerator, "&" & Page.Accelerator, 1, 1, vbTextCompare)

    If IsTagged Then
        TagArray = Split(Page.Tag, "||")
        lFontColor = CLng(TagArray(0))
        Call TranslateColor(CLng(TagArray(1)), 0, lBackColor)
        bExtendTabColToPage = CBool(TagArray(2))
        lTabShape = TagArray(3)
        bPaint = TagArray(4)
    End If
  
    If bPaint = False Then
        lFontColor = 0&
        Call TranslateColor(Page.Parent.BackColor, 0, lBackColor)
    End If
  
    Call CopyMemory(tTabRect, ByVal pRect, LenB(tTabRect))

    If Page Is Page.Parent.SelectedItem Then
        With tTabRect
            .Top = .Top - 20
        End With
    End If
  
    With tTabRect
        p1.x = .Left + 1: p1.Y = .Top
        p2.x = .Right: p2.Y = .Bottom + 2
    End With
    Call ScreenToClient(hwnd, p1)
    Call ScreenToClient(hwnd, p2)
    With tTabRect
        .Left = p1.x:     .Top = p1.Y
        .Right = p2.x: .Bottom = p2.Y
    End With
  
    With tTabRect

        lWidth = .Right - .Left:  lHeight = .Bottom - .Top
        hdc = GetDC(hwnd)
        hMemDC = CreateCompatibleDC(hdc)
        hMemBmp = CreateCompatibleBitmap(hdc, lWidth, lHeight)
        hOldBmp = SelectObject(hMemDC, hMemBmp)
        hBrush = CreateSolidBrush(lBackColor)
        hRegion = CreateRectRgn(0, 0, lWidth, lHeight)
        OldBrush = SelectObject(hMemDC, hBrush)
        Call FillRgn(hMemDC, hRegion, hBrush)
        Call SelectObject(hMemDC, OldBrush)
        Call DeleteObject(hBrush)
    
        tSI.GdiplusVersion = 1
        lRes = GdiplusStartup(lToken, tSI)
      
        If lRes = S_OK Then
            lRes = GdipCreateFromHDC(hMemDC, hGraphics)
            GdipSetSmoothingMode hGraphics, SmoothingModeAntiAlias
  
            Select Case lTabShape
  
                Case Flat
                    lPenColor = RGBtoARGB(lFontColor, 255)
                    Call GdipCreatePen1(lPenColor, 1, UnitPixel, hPen)
                    Call GdipSetPenDashStyle(hPen, DashStyleSolid)
                    If Page Is Page.Parent.SelectedItem Then
                        Call GdipDrawRectangle(hGraphics, hPen, 0, 18, lWidth - 1, lHeight - 1)
                    Else
                        Call GdipDrawRectangle(hGraphics, hPen, 0, 0, lWidth - 1, lHeight - 1)
                    End If
                    Call GdipDeletePen(hPen)
          
                Case Bumped
                    lPenColor = RGBtoARGB(0, 255)
                    Call GdipCreatePen1(lPenColor, 4, UnitPixel, hPen)
                    Call GdipSetPenDashStyle(hPen, DashStyleSolid)
                    Call GdipDrawLine(hGraphics, hPen, lWidth, 1, lWidth, lHeight)
                    If Page Is Page.Parent.SelectedItem Then
                        Call GdipSetPenColor(hPen, RGBtoARGB(0, 200))
                        Call GdipSetPenWidth(hPen, 1)
                        Call GdipDrawLine(hGraphics, hPen, 2, 18, lWidth, 18)
                        GdipSetPenWidth hPen, 2
                        GdipSetPenColor hPen, RGBtoARGB(0, 180)
                        Call GdipDrawLine(hGraphics, hPen, 1, 0, 1, lHeight)
                        GdipSetPenWidth hPen, 2
                        GdipSetPenColor hPen, RGBtoARGB(vbWhite, 255)
                        Call GdipDrawLine(hGraphics, hPen, 0, 0, 0, lHeight)
                        Call GdipDeletePen(hPen)
                    End If
                
                Case Trapezoid
                    tPoly(1).x = IIf(Page Is Page.Parent.SelectedItem, lWidth, lWidth - lWidth / 2)
                    tPoly(1).Y = 0
                    tPoly(2).x = lWidth
                    tPoly(2).Y = 0
                    tPoly(3).x = lWidth
                    tPoly(3).Y = IIf(Page Is Page.Parent.SelectedItem, lHeight, lHeight / 2)
                    Call TranslateColor(Page.Parent.BackColor, 0, lRealColor)
                    Call GdipCreateSolidFill(RGBtoARGB(lRealColor, 255), hBrush)
                    lPenColor = RGBtoARGB(lRealColor, 255)
                    Call GdipCreatePen1(lPenColor, 1, UnitPixel, hPen)
                    GdipDrawPolygon hGraphics, hPen, tPoly(1), 3
                    GdipFillPolygon hGraphics, hBrush, tPoly(1), 3, 0
                    GdipSetPenColor hPen, RGBtoARGB(lFontColor, 255)
                    Call GdipDrawLine(hGraphics, hPen, 0, 0, tPoly(1).x + 2, 0)
                    Call GdipDrawLine(hGraphics, hPen, 0, 0, 0, lHeight)
                    Call GdipDrawLine(hGraphics, hPen, tPoly(1).x - 1, tPoly(1).Y - 1, tPoly(3).x - 1, tPoly(3).Y - 1)
                    Call GdipSetPenWidth(hPen, 4)
                    Call GdipDrawLine(hGraphics, hPen, tPoly(3).x, tPoly(3).Y - 1, tPoly(3).x, lHeight)
                    If Page Is Page.Parent.SelectedItem Then
                        Call GdipSetPenColor(hPen, RGBtoARGB(vbWhite, 255))
                        Call GdipSetPenWidth(hPen, 1)
                        Call GdipDrawLine(hGraphics, hPen, 0, 7, tPoly(2).x + 2, 7)
                        Call GdipSetPenColor(hPen, RGBtoARGB(lFontColor, 255))
                        Call GdipSetPenWidth(hPen, 2)
                        Call GdipDrawLine(hGraphics, hPen, 0, 18, tPoly(3).x, 18)
                    End If
                    Call GdipDeleteBrush(hBrush)
                    Call GdipDeletePen(hPen)
        
            End Select
        
            Call GdipDeleteGraphics(hGraphics)
          
        End If
                        
        Call GdiplusShutdown(lToken)
          
        hFont = GetStockObject(DEFAULT_GUI_FONT)
        hPrevFont = SelectObject(hMemDC, hFont)
        Call SetBkMode(hMemDC, TRANSPARENT)
        Call SetTextColor(hMemDC, lFontColor)
      
        If Page Is Page.Parent.SelectedItem Then
            Call SetRect(tTextRect, 4, 21, lWidth - 4, lHeight - 4)
            Call DrawText(hMemDC, sCaption, Len(sCaption), tTextRect, DT_VCENTER + DT_CENTER)
            If GetFocus = hwnd Then
                Call DrawFocusRect(hMemDC, tTextRect)
            End If
        Else
            Call SetRect(tTextRect, 4, 2, lWidth, lHeight)
            Call DrawText(hMemDC, sCaption, Len(sCaption), tTextRect, IIf(lTabShape = Trapezoid, DT_LEFT, DT_VCENTER))
        End If
          
        Call BitBlt(hdc, .Left, .Top, lWidth, lHeight, hMemDC, 0, 0, SRCCOPY)

    End With
  
    Call ZeroMemory(tTabRect, ByVal LenB(tTabRect))
  
    If bExtendTabColToPage Then
        Call DrawEntirePage(Page, lBackColor)
    End If
  
    Call SelectObject(hMemDC, hOldBmp)
    Call SelectObject(hMemDC, hPrevFont)
  
    Call DeleteDC(hMemDC)
    Call DeleteObject(hMemBmp)
    Call DeleteObject(hFont)
    Call DeleteObject(hRegion)
    Call ReleaseDC(hwnd, hdc)

End Sub


Private Sub DrawEntirePage(ByVal Page As Object, ByVal Col As Long)

     Const IMAGE_BITMAP = 0
     Const PICTYPE_BITMAP = 1
     Const LR_COPYRETURNORG = &H4
     Const S_OK = 0&
  
    #If Win64 Then
        Dim hdc As LongLong, hMemBmp As LongLong, hMemDC As LongLong, hBrush As LongLong
        Dim hCopy As LongLong, OldMemBmp As LongLong
    #Else
        Dim hdc As Long, hMemBmp As Long, hMemDC As Long, hBrush As Long
        Dim hCopy As Long, OldMemBmp As Long
    #End If

    Dim tBmpRect As RECT
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim iPic As IPicture

    hdc = GetDC(0)
    SetRect tBmpRect, 0, 0, 1, 1

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

    hMemDC = CreateCompatibleDC(hdc)
    OldMemBmp = SelectObject(hMemDC, hMemBmp)
    hBrush = CreateSolidBrush(Col)

    Call FillRect(hMemDC, tBmpRect, 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
    End If

    Call SelectObject(hMemDC, OldMemBmp)
    Call DeleteObject(hMemBmp)
    Call DeleteObject(hMemDC)
    Call DeleteObject(hBrush)
    Call ReleaseDC(0, hdc)

End Sub


#If Win64 Then
    Private Sub DrawPageOutline(ByVal IsTagged As Boolean, ByVal hwnd As LongLong, ByVal Page As Object, ByVal pRect As LongLong)
        Dim hdc As LongLong, hPen As LongLong, hOldPen As LongLong
#Else
    Private Sub DrawPageOutline(ByVal IsTagged As Boolean, ByVal hwnd As Long, ByVal Page As Object, ByVal pRect As Long)
        Dim hdc As Long, hPen As Long, hOldPen As Long
#End If

    Const GW_CHILD = 5
    Const PS_SOLID = 0&

    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim tPen As LOGPEN, tpt As POINTAPI
    Dim tMultiPageRect As RECT
    Dim lPenColor As Long
    Dim TagArray As Variant
    Dim sCaption As String
    Dim lBackColor As Long
    Dim bExtend As Boolean
    Dim tCurTabRect As RECT
  
    hwnd = GetNextWindow(hwnd, GW_CHILD)
    GetClientRect hwnd, tMultiPageRect
    hdc = GetDC(hwnd)
  
   Call UpdateWindow(hwnd)

    With tPen
        .lopnColor = vbWhite
        .lopnStyle = PS_SOLID
        .lopnWidth.x = 2
        .lopnWidth.Y = 1
    End With
    hPen = CreatePenIndirect(tPen)
    hOldPen = SelectObject(hdc, hPen)
    With tMultiPageRect
        Call MoveToEx(hdc, .Left, .Bottom, tpt)
        Call LineTo(hdc, .Left, .Top)
        Call MoveToEx(hdc, .Left, .Top, tpt)
        Call LineTo(hdc, .Right, .Top)
        Call SelectObject(hdc, hOldPen)
        DeleteObject hPen
        Call TranslateColor(&H80000010, 0, lPenColor)
        With tPen
            .lopnColor = lPenColor
            .lopnStyle = PS_SOLID
            .lopnWidth.x = 5
            .lopnWidth.Y = 5
        End With
        hPen = CreatePenIndirect(tPen)
        hOldPen = SelectObject(hdc, hPen)
        Call MoveToEx(hdc, .Right, .Top, tpt)
        Call LineTo(hdc, .Right, .Bottom)
        Call MoveToEx(hdc, .Right, .Bottom, tpt)
        Call LineTo(hdc, .Left, .Bottom)
    End With

    Call SelectObject(hdc, hOldPen)
    Call DeleteObject(hPen)

    If IsTagged Then
        TagArray = Split(Page.Tag, "||")
        Call TranslateColor(CLng(TagArray(1)), 0, lBackColor)
    Else
        Call TranslateColor(Page.Parent.BackColor, 0, lBackColor)   ' <= !
    End If
      
    Call CopyMemory(tCurTabRect, ByVal pRect, LenB(tCurTabRect))
      
    With tCurTabRect
        p1.x = .Left: p1.Y = .Top
        p2.x = .Right: p2.Y = .Bottom + 2
    End With
    Call ScreenToClient(hwnd, p1)
    Call ScreenToClient(hwnd, p2)
    With tCurTabRect
        .Left = p1.x:     .Top = p1.Y
        .Right = p2.x: .Bottom = p2.Y
    End With
  
    With tPen
        .lopnColor = lBackColor
        .lopnStyle = PS_SOLID
        .lopnWidth.x = 2
        .lopnWidth.Y = 1
    End With
    hPen = CreatePenIndirect(tPen)
    hOldPen = SelectObject(hdc, hPen)

    With tCurTabRect
        Call MoveToEx(hdc, .Left, .Bottom, tpt)
        Call LineTo(hdc, .Right - 2, .Bottom)
    End With

    Call ZeroMemory(tCurTabRect, ByVal LenB(tCurTabRect))
  
    Call SelectObject(hdc, hOldPen)
    Call DeleteObject(hPen)
    Call ReleaseDC(hwnd, hdc)

End Sub


#If Win64 Then
    Private Function GetPageRect(ByVal Page As Object, ByVal hwnd As LongLong) As RECT
#Else
    Private Function GetPageRect(ByVal Page As Object, ByVal hwnd As Long) As RECT
#End If
  
    'A design-time reference to the UIAutomationClient library is required for this routine.
  
    Const UIA_TabItemControlTypeId = &HC363&

    Dim oAutomation As CUIAutomation
    Dim oAllElements As IUIAutomationElementArray
    Dim oElement As IUIAutomationElement
    Dim oCondition As IUIAutomationCondition
    Dim tTagRect As RECT, i As Long
  
    On Error Resume Next
  
    Set oAutomation = New CUIAutomation
    Set oElement = oAutomation.ElementFromHandle(ByVal hwnd)
    Set oCondition = oAutomation.CreateTrueCondition
    Set oAllElements = oElement.FindAll(TreeScope_Descendants, oCondition)
  
    For i = 0 To oAllElements.Length - 1
        Set oElement = oAllElements.GetElement(i)
        If oElement.CurrentControlType = UIA_TabItemControlTypeId Then
            If oElement.CurrentName = Page.Caption Then
                Call CopyMemory(tTagRect, oElement.CurrentBoundingRectangle, LenB(tTagRect))
                GetPageRect = tTagRect
                Call ZeroMemory(tTagRect, ByVal LenB(tTagRect))
                Exit Function
            End If
        End If
    Next i
  
End Function


#If Win64 Then
    Private Function WinProcAddr() As LongLong
        WinProcAddr = VBA.CLngLng(AddressOf WndProc)
    #Else
    Private Function WinProcAddr() As Long
        WinProcAddr = VBA.CLng(AddressOf WndProc)
    #End If
End Function


Private Function RGBtoARGB(ByVal RGBColor As Long, ByVal Opacity As Long) As Long

    If (RGBColor And &H80000000) Then RGBColor = GetSysColor(RGBColor And &HFF&)
    RGBtoARGB = (RGBColor And &HFF00&) Or (RGBColor And &HFF0000) \ &H10000 Or (RGBColor And &HFF) * &H10000
    If Opacity < 128 Then
        If Opacity < 0& Then Opacity = 0&
        RGBtoARGB = RGBtoARGB Or Opacity * &H1000000
    Else
        If Opacity > 255& Then Opacity = 255&
        RGBtoARGB = RGBtoARGB Or (Opacity - 128&) * &H1000000 Or &H80000000
    End If
  
End Function


'______________________SAFETY ROUTINES IN CASE OF AN UNHANDLED ERROR_______________________

#If Win64 Then
    Private Function SafeSubclassingHookFunction(ByVal ncode As Long, ByVal wParam As LongLong, lParam As CWPSTRUCT) As LongLong
#Else
    Private Function SafeSubclassingHookFunction(ByVal ncode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long
#End If

    Const WM_CREATE = &H1
    Dim strClass As String * 256

    If lParam.message = WM_CREATE Then
        strClass = Left(strClass, GetWindowText(lParam.hwnd, ByVal strClass, 256))
        If InStr(1, strClass, "Microsoft Visual Basic") Then
            Call SafeExit
            Call UnhookWindowsHookEx(hHook)
        End If
    End If
  
    SafeSubclassingHookFunction = CallNextHookEx(hHook, ncode, wParam, ByVal lParam)
  
End Function


Private Sub SafeExit()

    Dim oMul As Control
    Dim oUserForm As Object
  
    For Each oUserForm In VBA.UserForms
        For Each oMul In oUserForm.Controls
            If TypeOf oMul Is MultiPage Then
                Call RemoveWindowSubclass(oMul.[_GethWnd], WinProcAddr, ObjPtr(oMul))
                Call RemoveProp(oMul.[_GethWnd], "MultiPageSubclassed")
            End If
        Next oMul
    Next oUserForm

End Sub

2- Code Usage as per the Demo Workbook.


UserForm1:

Option Explicit

Private Sub UserForm_Initialize()

    PaintTab Me.MultiPage1.Pages(0), 1, vbRed, , False, Flat
    PaintTab Me.MultiPage1.Pages(1), 1, vbBlack, , False, Flat
    PaintTab Me.MultiPage1.Pages(2), 1, vbBlue, , False, Flat
    PaintTab Me.MultiPage1.Pages(3), 1, vbMagenta, , False, Flat
    PaintTab Me.MultiPage1.Pages(4), 1, vbGreen, , False, Flat

    PaintTab Me.MultiPage2.Pages(0), True, vbBlack, &HFFC0FF, True, Bumped
    PaintTab Me.MultiPage2.Pages(1), True, vbMagenta, vbGreen, True, Bumped
    PaintTab Me.MultiPage2.Pages(2), True, RGB(100, 2, 150), vbCyan, True, Bumped
    PaintTab Me.MultiPage2.Pages(3), True, RGB(200, 200, 80), vbRed, True, Bumped

    PaintTab Me.MultiPage3.Pages(0), True, vbBlack, &HFFFFC0, True, Flat
    PaintTab Me.MultiPage3.Pages(1), True, vbMagenta, vbGreen, True, Trapezoid
    PaintTab Me.MultiPage3.Pages(2), True, vbWhite, &H8000&, True, Trapezoid
    PaintTab Me.MultiPage3.Pages(3), True, vbYellow, &H8080FF, True, Bumped
    PaintTab Me.MultiPage3.Pages(4), True, vbRed, vbCyan, True, Bumped

    PaintTab Me.MultiPage4.Pages(0), True, vbBlack, vbGreen, True, Trapezoid
    PaintTab Me.MultiPage4.Pages(1), True, vbRed, vbYellow, True, Trapezoid
    PaintTab Me.MultiPage4.Pages(2), True, vbBlue, vbWhite, True, Trapezoid
    PaintTab Me.MultiPage4.Pages(3), True, 0, vbRed, True, Trapezoid

End Sub

Private Sub BtnShowForm2_Click()
    UserForm2.Show vbModal
End Sub

Private Sub BtnClose_Click()
    Unload Me
End Sub

UserForm2:

Option Explicit

Private Sub UserForm_Initialize()
    PaintTab Me.MultiPage1.SelectedItem, True, vbRed, &H80FFFF, True, Flat
End Sub

Private Sub MultiPage1_Change()

    Dim oPage As Control

    For Each oPage In Me.MultiPage1.Pages
        PaintTab oPage, IIf(oPage Is Me.MultiPage1.SelectedItem, True, False), vbRed, &H80FFFF, True, Flat
    Next oPage

End Sub

Tested on excel 2007,2010 and 2016 32bit and x64bit.... I hope this works consistently accross different platforms.

 

[MiNoSwe]

Hi your API works fine in Office 365 64bit / Windows 10 64 bit BUT you MUST select the UIAutomation references in TOOLS - References or else it will crash badly.
These references were not selected as standard in my Office install.
Thanks for the great work, now the multipage looks really awesome in my project.
/Mike from Sweden

 

[Jaafar Tribak]

Hi your API works fine in Office 365 64bit / Windows 10 64 bit BUT you MUST select the UIAutomation references in TOOLS - References or else it will crash badly.
These references were not selected as standard in my Office install.
Thanks for the great work, now the multipage looks really awesome in my project.
/Mike from Sweden

Hi Mike.

I actually mentioned in a comment in the GetPageRect routine that we need to set a reference to the UIAutomation library.

Anyway, I am glad you found the code useful and thanks for the feedback.

 

[JoseDanny57]

La respuesta dada a esta pregunta, esperaba me ayudara, pero excede mis conocimientos. Sería posible una respuesta más simple, solo quiero cambiar la pestaña, no el cuerpo de toda la página, algo como el primer ejemplo. Gracias!!

 

[Jaafar Tribak]

La respuesta dada a esta pregunta, esperaba me ayudara, pero excede mis conocimientos. Sería posible una respuesta más simple, solo quiero cambiar la pestaña, no el cuerpo de toda la página, algo como el primer ejemplo. Gracias!!

Hola Jose,

No es necesario preocuparse del principal codigo contenido en el Modulo Standard (bas_API). Tan solo necesitas llamar la funcion PaintTab desde tu formulario pasando los parametros adecuados para cada pestaña de la siguiente manera:

PaintTab Me.MultiPage1.Pages(0&), 1&, , &HADCBF8, , Bumped

Aquí hay una demostración del libro de trabajo
MP.xlsm