VB-Tec.de Visual Basic - Technik, FAQ, Tricks, Beispiele

Einleitung

Möchte man Bildschirm- und Drucker-Ausgaben "synchronisieren" (so dass sie wirklich erkennbar gleich aussehen, etwa für eine Vorschau) sollte man für beide Anwendungsfälle den gleichen Font benutzen. Leider entspricht die Menge der Bildschirm-Fonts nicht unbedingt der Menge der Drucker-Fonts.

Abhilfe schafft die u.g. SecureFonts-Funktion, welche gerade die Schnittmenge der Bildschirm- und Drucker-Fonts zurückgibt.

Beispiel

Das folgende Beispiel benutzt die unten definierte SecureFonts-Collection, um eine ComboBox mit den "sicheren" Font-Namen zu füllen:

Private Sub Form_Load()
  Dim vFont As Variant
  
  With cmbFont
    '.Sorted = True
    '.Style = 2 'Dropdown List
    .Clear
    
    For Each vFont In SecureFonts
      If Len(vFont) Then .AddItem vFont
    Next vFont
    
    If SecureFonts.Count Then .ListIndex = 0
  End With
End Sub

Code / Quelltext

Der folgende Code ist eigentlich relativ einfach: Erst werden alle Drucker-Fonts in eine Collection geladen. Dann werden alle Bildschirm-Fonts darauf getestet, ob sie in dieser Collection vorkommen. Übereinstimmende Treffer werden in der SecureFonts-Collection gesammelt.

Durch Nutzung der statischen colFonts-Variable muss dieser Prozess nur beim ersten Aufruf durchgeführt werden - es sei denn, man setzt den optionalen Refresh-Parameter auf True. Der wiederholte Aufruf dieser Funktion ist dadurch deutlich schneller (etwa Faktor 100 - je nach Font-Anzahl).

Public Function SecureFonts( _
    Optional ByVal Refresh As Boolean = False _
    ) As Collection
  'Deklarationen:
  Static colFonts As Collection
  Dim i As Long
  Dim IsInCollection As Boolean
  
  If (colFonts Is Nothing) Or Refresh Then
  
    'Kandidaten (d.h. Drucker-Fonts) sammeln:
    Set colFonts = New Collection
    With Printer
      For i = 1 To .FontCount
        colFonts.Add True, .Fonts(i)
      Next i
    End With
    
    'In Bildschirm-Fonts nach Duplikaten suchen:
    Set SecureFonts = New Collection
    With Screen
      For i = 1 To .FontCount
      
        'Check auf Treffer:
        On Error Resume Next
          IsInCollection = colFonts(.Fonts(i))
        On Error GoTo 0
        If IsInCollection Then
          SecureFonts.Add .Fonts(i)
          IsInCollection = False
        End If
      
      Next i
    End With
    
    'Ergebnis cachen:
    Set colFonts = SecureFonts
  
  Else
  
    'Cache benutzen:
    Set SecureFonts = colFonts
  
  End If
End Function