vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Blitzschnelles Erstellen von grafischen Diagrammen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Grafik und Font · Font & Text   |   VB-Versionen: VB4, VB5, VB624.07.01
Schriftauswahl per PopUp-Menü realisieren

Ein Klick auf ein CommandButton öffnet ein PopUp-Menü mit allen zur Verfügung stehenden Schriften.

Autor:   Dieter OtterBewertung:     [ Jetzt bewerten ]Views:  19.117 
www.tools4vb.deSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

Das nachfolgende Beispiel zeigt, wie sich ein PopUp-Menü realisieren und aufrufen lässt, welches alle auf dem System installierten Schriften anzeigt. Zusätzlich wird im PopUp-Menü die aktuell gewählte Schrift mit einem Häkchen gekennzeichnet. Beim Beenden des Formulars lässt sich die zuletzt eingestellte Schrift speichern und kann so bei Bedarf bei einem erneuten Formular-Aufruf gleich wieder eingestellt werden.

Wie funktioniert das?
Erstellen Sie unter Verwendung des VB-Menüeditors ein Menü mit dem "Namen" PopUpFont und Caption Schriften. Setzen Sie dann die Visible-Eigenschaft auf False, so daß das Menü nicht in der Formular-Menüleiste angezeigt wird. Klicken Sie im Menüeditor auf Nächster und dann auf den kleinen nach rechts zeigenden Pfeil, um ein Menüeintrag für das PopUp-Menü zu erstellen. Tragen Sie in die Zeile "Name" den Text mnuFont ein und in der Zeile "Index" den Wert 0. Dies signalisiert, daß es sich um ein Steuerelementfeld handelt, so daß weitere Untermenüpunkte zur Laufzeit erzeugt werden können. Und genau diese Funktionalität nutzt die nachfolgende Routine.

Im Form_Load-Ereignis wird das Schriftarten-Menü zur Laufzeit erzeugt. Im Click-Ereignis des entsprechenden Buttons wird das Menü dann per PopUpMenu-Anweisung an der aktuellen Mausposition angezeigt.

Private Sub Form_Load()
  ' Schriften ermitteln und in Array speichern
  Dim sFont() As String
  Dim nCount As Long
  Dim i As Long
  Dim F As Integer
  Dim sOldFont As String
 
  ' Bildschirmschriften
  nCount = Screen.FontCount
  ReDim Preserve sFont(nCount)
  For i = 0 To Screen.FontCount - 1
    sFont(i + 1) = Screen.Fonts(i)
  Next i
 
  ' Druckerschriften
  For i = 0 To Printer.FontCount - 1
    If Not IsInArray(sFont, Printer.Fonts(i)) Then
      nCount = nCount + 1
      ReDim Preserve sFont(nCount)
      sFont(nCount) = Printer.Fonts(i)
    End If
  Next i
 
  ' Schrift-Array alphabetisch sortieren
  BSort sFont(), 0
 
  ' zuletzte verwendete Schrift ermitteln
  sOldFont = Text1.Font.Name
  If Dir$(App.Path & "\font.dat", vbNormal) <> "" Then
    F = FreeFile
    Open App.Path & "\font.dat" For Input As #F
    Line Input #F, sOldFont
    Close #F
 
    ' zuletzt verwendete Schriftart zuweisen
    Text1.Font.Name = sOldFont
  End If
 
  ' PopUp-Menü erstellen
  For i = 0 To nCount - 1
    ' Ggf. Menu-Element laden
    If i > 0 Then Load mnuFont(i)
 
    ' Caption (Menütext)
    mnuFont(i).Caption = sFont(i + 1)
 
    ' wenn aktueller Schrifteintrag = Standard-Schrift
    mnuFont(i).Checked = (sFont(i + 1) = sOldFont)
  Next i
End Sub
 
' PopUp-Menü anzeigen
Private Sub cmdFont_Click()
  ' Schriften-PopUp-Menü anzeigen
  PopupMenu PopUpFont
End Sub
 
' Neue Schrift ausgewählt
Private Sub mnuFont_Click(Index As Integer)
  Dim i As Integer
  Dim F As Integer
 
  ' Beispiel: TextBox in neuer Schrift anzeigen
  Text1.Font.Name = mnuFont(Index).Caption
 
  ' Neue Schrift als Standard setzen
  For i = 0 To mnuFont.Ubound
    mnuFont(i).Checked = (i = Index)
  Next i
 
  ' Gewählte Schrift speichern
  On Local Error Resume Next
  F = FreeFile
  Open App.Path & "\font.dat" For Output As #F
  Print #F, mnuFont(Index).Caption
  Close #F
End Sub

Hilfsroutinen

' Prüft, ob der String bereits im Array-Feld vorhanden
Public Function IsInArray(ByRef sArray() As String, _
  sString As String) As Boolean
 
  Dim i As Integer
 
  IsInArray = False
  For i = LBound(sArray) To UBound(sArray)
    If sArray(i) = sString Then
      IsInArray = True
      Exit For
    End If
  Next i
End Function
 
' BubbleSort-Routine 
Private Sub BSort(SortField As Variant, Modus)
  Dim i As Long
  Dim Flag As Boolean
  Dim z As Variant
  Do
    Flag = True
    For i = 0 To UBound(SortField, 1) - 1
      If Modus = 0 Then ' aufsteigende Sortierung
        If SortField(i) > SortField(i + 1) Then
          z = SortField(i)
          SortField(i) = SortField(i + 1)
          SortField(i + 1) = z
          Flag = False
        End If
      Else              ' absteigende Sortierung
        If SortField(i) < SortField(i + 1) Then
          z = SortField(i)
          SortField(i) = SortField(i + 1)
          SortField(i + 1) = z
          Flag = False
        End If
      End If
    Next i
  Loop Until Flag = True
End Sub

Dieser Tipp wurde bereits 19.117 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel