Option Explicit 
 
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 GetMenuItemID 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 Any) As Long 
 
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BITMAP = &H4&
 
 
' Variablen für Handles und sonst deklarieren : 
Dim hMenu&, hSubMenu&, menuID&
Dim i&, n&

Private Sub changeMenu() ' ändert das Schriftartenmenü 
  For i = 0 To n   ' jeder Eintrag wird durch Bitmap ersetzt 
  ' Laden des i-ten Bildfelds mit Schrift : 
  bild1(i).Font.Name = Screen.fonts(i)
  bild1(i).Height = bild1(i).TextHeight(Screen.fonts(i))
  bild1(i).Print Screen.fonts(i)     ' Eintragen des Fontnamens 
  bild1(i).Picture = bild1(i).Image  ' wird zum Hintergrundbild 
  ' Aufruf der API-Funktionen für Änderung des i-ten Eintrags : 
  menuID = GetMenuItemID(hSubMenu, i) ' Menü-Handle für i-ten Eintrag 
  Call ModifyMenu(hMenu, menuID, MF_BYCOMMAND Or MF_BITMAP, menuID, CLng(bild1(i).Picture))
  Next i
End Sub 

Private Sub Form_Load()
  ' Aufruf der API-Funktionen für Menü-Handle-Ermittlung : 
 hMenu = GetMenu(hwnd)             ' gesamtes Menü 
 hSubMenu = GetSubMenu(hMenu, 0)   ' Schriftfonts-Menü 
  ' Aufbau einer leeren Menüliste und eines Bildfeld-Arrays : 
  n = Screen.FontCount - 1  ' maximale Anzahl von Bildschirmfonts 
  If n > 25 Then n = 25     ' Begrenzung auf 25 Menüeinträge 
  For i = 1 To n            ' Elemente mit Index 0 bereits vorhanden ! 
    Load mnuF1(i)           ' Hinzufügen eines (Dummy) Menüeintrags 
    Load bild1(i)           ' Hinzufügen eines (leeren) Bildfelds 
  Next i
 
  Call changeMenu
 
End Sub 

Private Sub mnuF1_Click(Index As Integer)
'Click auf Menüeintrag zeigt die ausgewählte 
'Schrift im Text an... 
    Text1.Font = Screen.fonts(Index)
    Label1.Caption = "Ausgewählte Schrift: " & Screen.fonts(Index)
 
End Sub