Attribute VB_Name = "ColorUtilities"
Option Explicit
Private Type MENUINFO
    cbSize As Long
    fMask As Long
    dwStyle As Long
    cyMax As Long
    hbrBack As Long
    dwContextHelpID As Long
    dwMenuData As Long
End Type

'Déclaration des API
Private Declare Function SetMenuInfo Lib "user32" (ByVal hMenu As Long, mi As MENUINFO) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Function FormMenuColour(ByVal lhForm As Long, ByVal lMenuColor As Long, Optional ByVal bIncludeSubMenus As Boolean = True, Optional lMenuIndex As Long = -1) As Boolean
    Const MIM_BACKGROUND As Long = &H2, MIM_APPLYTOSUBMENUS As Long = &H80000000
    Dim tMenuInf As MENUINFO
    Dim lFlags As Long
    Dim lRGBColor As Long
    Dim lhMenu As Long
    On Error GoTo ErrFailed
    'Convertis une couleur windows (ole) en RGB
    OleTranslateColor lMenuColor, 0, lRGBColor
    'les Flags...
    lFlags = MIM_BACKGROUND
    If bIncludeSubMenus Then
        'Changer la couleur de fond de tous les sous-menus
        lFlags = lFlags Or MIM_APPLYTOSUBMENUS
    End If
    With tMenuInf
        .cbSize = Len(tMenuInf)
        .fMask = lFlags
        .hbrBack = CreateSolidBrush(lRGBColor)
    End With
    If lMenuIndex <> -1 Then
        'Appliquer la couleur à un mlenu spécifié
        lhMenu = GetSubMenu(GetMenu(lhForm), lMenuIndex)
    Else
        'Appliquer la couleur a un menu spécifié
        lhMenu = GetMenu(lhForm)
    End If
    If lhMenu Then
        SetMenuInfo lhMenu, tMenuInf
        FormMenuColour = (Err.LastDllError = 0)
        DrawMenuBar lhForm
    Else
        Debug.Print "Pas de menu..."
        FormMenuColour = False
    End If
    Exit Function
ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    FormMenuColour = False
End Function
