Startseite / Tipps / VB 5/6-Tipp 0639: Farbe von Menüs ändern

VB 5/6-Tipp 0639: Farbe von Menüs ändern

 von Wolfgang Ehrhardt

'Dieser Quellcode 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!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Menü "mnuFile"
' Steuerelement: Menü "mnuFileHere" auf mnuFile
' Steuerelement: Menü "mnuFileStands" auf mnuFile
' Steuerelement: Menü "mnuFileA" auf mnuFile
' Steuerelement: Menü "mnuFileText" auf mnuFileA
' Steuerelement: Menü "mnuHere"
' Steuerelement: Menü "mnuHereToo" auf mnuHere

Option Explicit

Private Sub Form_Click()
    PopupMenu mnuFile
End Sub

Private Sub Form_Load()
    Set_MenuColor mMenuColor, Me.Hwnd, vbBlue, 1, False
    Set_MenuColor mMenuBarColor, Me.Hwnd, vbRed
    Set_MenuColor mSysMenuColor, Me.Hwnd, vbYellow
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'---- Anfang Modul "modMenuColor" alias modMenuColor.bas ----



'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
'----- Ende Modul "modMenuColor" alias modMenuColor.bas -----
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

CreatePatternBrush(<MyBitmap>.Handle)

CreateSolidBrush(<Color>)