Attribute VB_Name = "modMenuColor"
 'Dieser Source stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!


'Geschrieben von Wolfgang Ehrhardt
'                   woeh@gmx.de
   
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function GetMenu Lib "user32" (ByVal Hwnd As Long) As Long

Private Declare Function DrawMenuBar Lib "user32" _
    (ByVal Hwnd As Long) As Long

Private Declare Function SetMenuInfo Lib "user32" _
    (ByVal Hmenu As Long, Mi As MENUINFO) 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 GetSystemMenu Lib "user32" _
    (ByVal Hwnd As Long, ByVal bRevert As Long) As Long

Private Declare Function GetMenuItemCountA Lib "user32" Alias _
    "GetMenuItemCount" (ByVal Hmenu As Long) As Long

Private Declare Function GetSubMenu Lib "user32" _
    (ByVal Hmenu As Long, ByVal nPos As Long) As Long

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

Public Enum MenuNFO
    mMenuBarColor = 1
    mMenuColor = 2
    mSysMenuColor = 3
End Enum

Private Const MIM_BACKGROUND As Long = &H2&
Private Const MIM_APPLYTOSUBMENUS As Long = &H80000000

'*** Dokumentation der Funktion ***
'Beschreibung
    'Färbt ein angegebenes MenuElement in eine angegebene Farbe ein.

'Rückgabewert
'True wenn MenuElement erfolgreich eingefärbt wurde

'Übergabewert(e)
'[SetWhat As MenuNFO]
    'mMenuBarColor
        'Färbt die MenuBar
        'MenuIndex & IncludeSubmenus kann weggelaßen werden
    'mMenuColor
        'Färbt einen Menueintrag mit/ohne Untermenueinträge
    'mSysMenuColor
        'Färbt das SystemMenu
        'MenuIndex & IncludeSubmenus kann weggelaßen werden
'Hwnd
    'Verweis auf das Hwnd des Menu-Owners
'Color
    'Farbe, in die eingefärbt werden soll
'Optional MenuIndex As Integer
    'Nur gültig bei mMenucolor
    'Einzufärbendes MenuElement
'Optional IncludeSubmenus As Boolean = False
    'Nur gültig bei mMenucolor
    'Wird True angegeben und hat das Menuelement eine Untermenu,
    'so wird dieses mitgefärbt.

Public Function Set_MenuColor(SetWhat As MenuNFO, _
    ByVal Hwnd As Long, ByVal Color As Long, _
    Optional MenuIndex As Integer, _
    Optional IncludeSubmenus As Boolean = False) As Boolean
    
    Dim Mi As MENUINFO
    Dim clrref As Long, hSysMenu As Long, mHwnd As Long
         
    On Local Error GoTo Quit
   
    clrref = Convert_OLEtoRBG(Color)
   
    Mi.cbSize = Len(Mi)
    Mi.hbrBack = CreateSolidBrush(clrref)
    
    Select Case SetWhat
        Case mMenuBarColor
            Mi.fMask = MIM_BACKGROUND
            Call SetMenuInfo(GetMenu(Hwnd), Mi)
            
        Case mMenuColor
            If MenuIndex = 0 Then
                Set_MenuColor = Set_MenuColor(mMenuBarColor, Hwnd, Color)
                Exit Function
            End If
            
            If MenuIndex < 1 Or Get_MenuItemCount(Hwnd) < MenuIndex Then _
                Exit Function
    
            Mi.fMask = IIf(IncludeSubmenus, _
                           MIM_BACKGROUND Or MIM_APPLYTOSUBMENUS, _
                           MIM_BACKGROUND)
            
            mHwnd = GetMenu(Hwnd)
            mHwnd = GetSubMenu(mHwnd, MenuIndex - 1)
        
            Call SetMenuInfo(mHwnd, Mi)
            Hwnd = mHwnd
            
        Case mSysMenuColor
            hSysMenu = GetSystemMenu(Hwnd, False)
   
            Mi.fMask = MIM_BACKGROUND _
                       Or MIM_APPLYTOSUBMENUS
            
            Call SetMenuInfo(hSysMenu, Mi)
            Hwnd = hSysMenu
    End Select
    
    Call DrawMenuBar(Hwnd)
    Set_MenuColor = True
Quit:
End Function

Private Function Convert_OLEtoRBG(ByVal OLEcolor As Long) As Long
    Call OleTranslateColor(OLEcolor, 0, Convert_OLEtoRBG)
End Function

Private Function Get_MenuItemCount(ByVal Hwnd As Long) As Long
    Get_MenuItemCount = GetMenuItemCountA(Get_MenuHwnd(Hwnd))
End Function

Private Function Get_MenuHwnd(ByVal Hwnd As Long) As Long
    Get_MenuHwnd = GetMenu(Hwnd)
End Function