title image


Smiley Re: Font-TESTER
hier der Code für die Ermittlung der Schriftarten. Musst ja nur noch soviele Labels oder ähnliches erzeugen, wie Schriftarten vorhanden sind. Und dann die Eigenschaft Font.Name=sFonts(i) oder so zuweisen:







      

' Dieser Code stammt von www.vbarchiv.de

' URL: http://www.vbarchiv.net/archiv/tipp_details.php?pid=278



Option Explicit

Dim sFont() As String



Public Sub SchriftenLaden(Optional txtAnzeige As TextBox)

' Schriften ermitteln und in Array speichern

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





' Hier werden alle Schriftarten in die Textbox eingefügt

With txtAnzeige

    For i = 0 To UBound(sFont)

        If sFont(i) <> "" Then

            .Text = .Text & sFont(i) & vbCrLf

        End If

    Next i

End With

End Sub



' Prüft, ob der String bereits im Array-Feld vorhanden

Private 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, Optional Modus As Integer = 0)

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





 









Gruß

Daniel
-----
Gegen unnötige Signaturwerbung :D



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: