Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0450: Alle Schriftarten schneller in eine ComboBox einlesen II

VB 5/6-Tipp 0450: Alle Schriftarten schneller in eine ComboBox einlesen II

 von Benjamin Wilger

Schwierigkeitsgrad:

Verwendete API-Aufrufe: EnumFontFamiliesExA (EnumFontFamiliesEx)

Download: Download des Beispielprojektes [2,83 KB]

'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 Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Kombinationsliste "Combo1"
'Code von Benjamin Wilger
'Benjamin@ActiveVB.de
'Copyright (C) 2001
Option Explicit

Private Sub Command1_Click()
    GetAllFonts Me.hDC, Combo1
    MsgBox "Fertig!"
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------- Anfang Modul "EnumFont" alias EnumFont.bas --------
' Code von Benjamin Wilger
' Benjamin@ActiveVB.de
' Copyright (C) 2001
Option Explicit

Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

Private Declare Function EnumFontFamiliesEx Lib "gdi32" _
                         Alias "EnumFontFamiliesExA" ( _
                         ByVal hDC As Long, _
                         lpLogFont As LOGFONT, _
                         ByVal lpEnumFontProc As Long, _
                         ByVal lParam As Long, _
                         ByVal dw As Long) As Long
                         
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type ENUMLOGFONTEX
    elfLogFont As LOGFONT
    elfFullName(LF_FULLFACESIZE) As Byte
    elfStyle(LF_FACESIZE) As Byte
    elfScript(LF_FACESIZE) As Byte
End Type

Private Const DEFAULT_CHARSET = 1
Private cboFonts As ComboBox
Private LastFont As String

Public Sub GetAllFonts(ByVal hDC As Long, cboBox As ComboBox)

    Dim lf As LOGFONT
    
    Set cboFonts = cboBox
    
    cboFonts.Clear
    lf.lfCharSet = DEFAULT_CHARSET
    EnumFontFamiliesEx hDC, lf, AddressOf EnumFontFamExProc, 0&, 0&
    
End Sub

Public Function EnumFontFamExProc(ByRef lpElfe As ENUMLOGFONTEX, ByVal _
    lpntme As Long, ByVal FontType As Long, ByVal lParam As Long) As Long
    
    Dim FaceName As String
    
    ByteArray2String lpElfe.elfLogFont.lfFaceName, FaceName
    
    If Not LastFont = FaceName Then cboFonts.AddItem FaceName
    
    LastFont = FaceName
    EnumFontFamExProc = 1
    
End Function

Public Function ByteArray2String(ByteArray() As Byte, OutputString As String)

    Dim i As Long
    
    OutputString = ""
    
    For i = 0 To UBound(ByteArray)
    
        If ByteArray(i) = 0 Then Exit For
        
        OutputString = OutputString & Chr(ByteArray(i))
        
    Next i
    
End Function


'--------- Ende Modul "EnumFont" alias EnumFont.bas ---------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.