fonts of menu

[avkvijai]

How to change the fonts of a menu control?

[Zero]

You don't. That's controlled by Windows, and can only be changed through the Display/Appearance settings. If you change it there, it affects ALL menus.

There is a workaround. Make your own menus with some labels and frame controls. Then you can have different fonts, colors, bitmaps, you name it.

-Zero the Inestimable

Try this method using API. I got a code and tried to simplify it as much as I could. This simplified version is not as flexible, but once you get the basic idea, you can increase flexibility by using Classes and more API's.

Make a Form with a CommandButton and a Menu (with some SubMenus) and put the following code into your Form. When you click the CommandButton, the Fonts for the first menu will change.

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 CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Const MF_BITMAP = &H4&
Const MF_STRING = &H0&

Private Sub Command1_Click()

        'Declare our Variables
        Dim hID As Long
        Dim hMenu As Long
        Dim hSubMenu As Long
        Dim hDC As Long
        Dim hFont As Long
        Dim hBmp As Long
        Dim lh()
        'The the DC and hWnd of the form and Menu's
        hMenu = GetMenu(Form1.hwnd)
        hSubMenu = GetSubMenu(hMenu, 0)
        hDC = CreateCompatibleDC(Me.hDC)
        'Get the number of SubMenus
        iCount = GetMenuItemCount(hSubMenu)
        ReDim lh(iCount)
        
        'Loop through the SubMenus
        For i = 0 To GetMenuItemCount(hSubMenu)
            
            hID = GetMenuItemID(hSubMenu, i)
            'Create the Font
            hFont = CreateFont(-16, 0, 0, 0, 400, 0, 0, 0, 0, 0, 0, 0, 0, Me.FontName)
            lh(i) = CreateCompatibleBitmap(hDC, 200, 18)
            hBmp = SelectObject(hDC, lh(i))
            
            SelectObject hDC, hFont
            Rectangle hDC, -1, -1, 201, 19
            'Set the Menu Text
            TextOut hDC, 0, 0, "SubMenu" & i, 8
            'Make the modifications
            ModifyMenu hSubMenu, hID, MF_BITMAP, hID, lh(i)

        Next i
        
End Sub

Private Sub Form_Load()

    'Change the FontName here
    Me.FontName = "Courier"
    
End Sub