ChooseFont-Funktion Diese Funktion ruft den Windows-Standard-Dialog zur Auswahl einer Schriftart auf.
Betriebssystem:  Win95, Win98, WinNT 3.1, Win2000, WinME	Views:  10.828

Deklaration:

Declare Function ChooseFont Lib "comdlg32.dll" _
  Alias "ChooseFontA" ( _
  lpcf As CHOOSEFONT_TYPE) As Long

Beschreibung:
Diese Funktion ruft den Windows-Standard-Dialog zur Auswahl einer Schriftart auf.

Parameter:

lpcf	Erwartet wird eine CHOOSEFONT_TYPE-Struktur.

Rückgabewert:
Ist die Funktion erfolgreich so ist der Rückgabewert ungleich 0. Tritt ein Fehler auf oder wird im Dialog auf Abbrechen gedrückt, so wird als Wert "0" zurückgegeben.

Beispiel:

Private Declare Function ChooseFont Lib "comdlg32.dll" _
  Alias "ChooseFontA" ( _
  lpcf As CHOOSEFONT_TYPE) 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 As String * 32
End Type
 
Private Type CHOOSEFONT_TYPE
  lStructSize As Long
  hwndOwner As Long
  hDC As Long
  lpLogFont As Long
  iPointSize As Long
  Flags As Long
  rgbColors As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
  hInstance As Long
  lpszStyle As String
  nFontType As Integer
  MISSING_ALIGNMENT As Integer
  nSizeMin As Long
  nSizeMax As Long
End Type
 
' Zeigt nur Windows- oder Unicode-Fonts
Private Const CF_ANSIONLY = &H400
' Zeigt einen "Übernehmen" Button an
Private Const CF_APPLY = &H200
' Listet Drucker- und Bildschirm-Fonts
Private Const CF_BOTH = &H3
' Erlaubt Font-Besonderheiten wie
' Unterstreichen, Farbe und Durchgestrichen
Private Const CF_EFFECTS = &H100
' Aktiviert die Callback-Funktion
Private Const CF_ENABLEHOOK = &H8
' Der Dialog benutzt Template's die von
' TemplateNames festgelegt sind
Private Const CF_ENABLETEMPLATE = &H10
' Verwendet den durch hInstance festgelegten Dialog
Private Const CF_ENABLETEMPLATEHANDLE = &H20
' Listet nur Fixed-Pitch Fonts
Private Const CF_FIXEDPITCHONLY = &H4000
' Verweigert die Eingabe nicht aufgeführter Fonts
Private Const CF_FORCEFONTEXIST = &H10000
' Setzt die Startwerte, welche über die 
' LOGFONT-Struktur angegeben wurden
Private Const CF_INITTOLOGFONTSTRUCT = &H40
' Erlaubt nur Schriftgrößen im Bereich "nSizeMin" und "nSizeMax"
Private Const CF_LIMITSIZE = &H2000
' Zeigt keine OEM Fonts
Private Const CF_NOOEMFONTS = &H800
' Kein Standard Facenamen selektieren
Private Const CF_NOFACESEL = &H80000
' Kein Standard Script selektieren
Private Const CF_NOSCRIPTSEL = &H800000
' keine Standardgröße setzen
Private Const CF_NOSIZESEL = &H200000
' Kein Beispiel (Vorschau) anzeigen
Private Const CF_NOSIMULATIONS = &H1000
' kein Standard-Stil setzen
Private Const CF_NOSTYLESEL = &H100000
' keine Vector-Fonts anzeigen
Private Const CF_NOVECTORFONTS = &H800
' keine vertikal ausgerichtete Fonts anzeigen
Private Const CF_NOVERTFONTS = &H1000000
' Listet Drucker-Fonts
Private Const CF_PRINTERFONTS = &H2
' Listet nur skalierbare Fonts
Private Const CF_SCALABLEONLY = &H20000
' Listet Bildschirm-Fonts
Private Const CF_SCREENFONTS = &H1
' Listet nur Windows- oder Unicode-Fonts
Private Const CF_SCRIPTSONLY = &H400
' Listet nur Script-Fonts
Private Const CF_SELECTSCRIPT = &H400000
' Zeigt den Hilfe-Button an
Private Const CF_SHOWHELP = &H4
' Listet nur TrueType-Schriftarten
Private Const CF_TTONLY = &H40000
' Verwendet die in "lpStyle" angegebenen Werte
Private Const CF_USESTYLE = &H80
' Listet nur Fonts, die Drucker- und Bildschirm-Fonts gleichzeitig sind
' (muss benutzt werden mit CF_BOTH und CF_SCALABLEONLY)
Private Const CF_WYSIWYG = &H8000
<br><br>
' nFontType Konstanten
' ====================
Private Const BOLD_FONTTYPE = &H100 ' fett
Private Const ITALIC_FONTTYPE = &H200 ' kursiv
Private Const PRINTER_FONTTYPE = &H4000 ' Drucker-Fonts
Private Const REGULAR_FONTTYPE = &H400 ' reguläre Fonts
Private Const SCREEN_FONTTYPE = &H2000 ' Bildschirm-Fonts
' Fonts, die in der Dialogbox simuliert werden können
Private Const SIMULATED_FONTTYPE = &H8000
<br><br>
' lfWeight Konstanten
' ===================
Private Const FW_DONTCARE = 0       ' Standard
Private Const FW_THIN = 100            ' super dünn
Private Const FW_EXTRALIGHT = 200  ' extra dünn
Private Const FW_LIGHT = 300         ' dünn
Private Const FW_NORMAL = 400       ' normal
Private Const FW_MEDIUM = 500      ' mittel
Private Const FW_SEMIBOLD = 600    ' etwas dicker
Private Const FW_BOLD = 700          ' fett
Private Const FW_EXTRABOLD = 800   ' extra fett
Private Const FW_HEAVY = 900         ' super fett
 
' lfCharSet Konstanten
' ====================
Private Const ANSI_CHARSET = 0               ' Ansi Zeichensatz
Private Const ARABIC_CHARSET = 178         ' Arabisch (NT/2000)
Private Const BALTIC_CHARSET = 186          ' Baltisch (Win 9x)
Private Const CHINESEBIG5_CHARSET = 136 ' Chinesisch
Private Const DEFAULT_CHARSET = 1         ' Standard
Private Const EASTEUROPE_CHARSET = 238 ' Osteuropäisch (Win 9x)
Private Const GB2312_CHARSET = 134         ' Englisch
Private Const GREEK_CHARSET = 161          ' Griechisch (Win 9x)
Private Const HANGEUL_CHARSET = 129      ' Handgeul
Private Const HEBREW_CHARSET = 177        ' Hebräisch (NT/2000)
Private Const JOHAB_CHARSET = 130         ' Johab (Win 9x)
Private Const MAC_CHARSET = 77               ' Mac (Win 9x)
Private Const OEM_CHARSET = 255             ' OEM
Private Const RUSSIAN_CHARSET = 204       ' Russisch (Win 9x)
Private Const SHIFTJIS_CHARSET = 128        ' ShiftJis
Private Const SYMBOL_CHARSET = 2           ' Symbolisch
Private Const THAI_CHARSET = 222             ' Thailändisch (NT/2000)
Private Const TURKISH_CHARSET = 162         ' Türkisch (Win 9x)
 
' lfOutPrecision Konstanten
' =========================
' Verwendet die Standard-Font
Private Const OUT_DEFAULT_PRECIS = 0
' Verwendet eine Device-Font wenn mehrere
' Dateien mit dem selben Namen existieren
Private Const OUT_DEVICE_PRECIS = 5
' (NT/2000) Verwendet eine TureType Schriftart
' oder Outline-Based Fonts.
Private Const OUT_OUTLINE_PRECIS = 8
' Verwendet ein Raster-Font, wenn mehrere
' Dateien mit dem selben Namen existieren
Private Const OUT_RASTER_PRECIS = 6
' Raster-Font für die Enumeration
Private Const OUT_STRING_PRECIS = 1
' (Win 9x) Vector-Font für die Enumeration
' (NT/2000) TrueType, Outline-Based oder VectorFont für die Enumeration
Private Const OUT_STROKE_PRECIS = 3
' Verwendet eine TrueType-Schriftart
Private Const OUT_TT_ONLY_PRECIS = 7
' Verwendet eine TrueType-Font, wenn mehrere
' Dateien mit dem selben Namen existieren
Private Const OUT_TT_PRECIS = 4
 
' lfClipPrecision Konstanten
' ==========================
' Standard
Private Const CLIP_DEFAULT_PRECIS = 0
' wird benutzt für eingebettete schreibgeschützte Fonts
Private Const CLIP_EMBEDDED = 128
' die Richtung von irgendwelchen Rotationen wird vom
' Koordinatensystem festgelegt (gegen den Uhrzeigersinn)
Private Const CLIP_LH_ANGLES = 16
' Raster-Vector oder TrueType-Fonts für die Enumeration
Private Const CLIP_STROKE_PRECIS = 2
 
' lfQuality Konstanten
' ====================
' (Win 9x, NT 4.0, 2000) Schriftart wird wenn möglich
' immer mit Anitialisierung gezeichnet
Private Const ANTIALIASED_QUALITY = 4
' Standard Qualität
Private Const DEFAULT_QUALITY = 0
' entspricht "Schnelldruck" bei Druckausgaben
Private Const DRAFT_QUALITY = 1
' (Win 9x, NT 4.0, 2000) Schriftart wird nicht mit
' Anitialisierung gezeichnet
Private Const NONANTIALIASED_QUALITY = 3
' entspricht "Schöndruck" bei Druckausgaben
Private Const PROOF_QUALITY = 2
 
' lfPitchAndFamily Konstanten
' ===========================
Private Const DEFAULT_PITCH = 0     ' Standard
Private Const FIXED_PITCH = 1          ' Fest
Private Const VARIABLE_PITCH = 2    ' Variabel
Private Const FF_DECORATIVE = 80   ' Dekoriert
Private Const FF_DONTCARE = 0       ' Egal
Private Const FF_MODERN = 48          ' Modern
Private Const FF_ROMAN = 16          ' Roman
Private Const FF_SCRIPT = 64          ' Script
Private Const FF_SWISS = 32             ' Swiss

Private Sub Command1_Click()
  Dim Retval As Long, TmpFName As String
  Static LFnt As LOGFONT, CF_T As CHOOSEFONT_TYPE
 
  ' Dialog-Eigenschaften setzen
  With CF_T
    .Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
    .hwndOwner = Me.hWnd
    .lStructSize = Len(CF_T)
    .lpLogFont = VarPtr(LFnt)
    .hInstance = App.hInstance
    .hDC = Printer.hDC
    .nFontType = SCREEN_FONTTYPE
    .rgbColors = 0
  End With
  If Trim$(LFnt.lfFaceName) = "" Then
    ' Nur zum Initialisieren Leerzeichen setzen
    LFnt.lfFaceName = Space(31) & vbNullChar
  Else
    ' ansonsten "alte Font" als Standard setzen
    LFnt.lfFaceName = Left$(LFnt.lfFaceName, Len(LFnt.lfFaceName) - 1) & vbNullChar 
  End If
 
  ' Dialog aufrufen
  Retval = ChooseFont(CF_T)
  If Retval = 0 Then
    MsgBox "Es ist ein Fehler im Dialog aufgetreten, " & _
      "oder Sie haben Abbrechen gewählt.", vbCritical, "Fehler"
    Exit Sub
  End If
 
  ' Struktur auswerten und dem Bildfeld zuweisen
  ' ============================================
  ' Fontnamen in Unicode konvertieren 
  TmpFName = StrConv(LFnt.lfFaceName, vbUnicode)
  With Picture1
    With .Font
      .Name = Left$(TmpFName, InStr(1, TmpFName, vbNullChar) - 1)
      .Bold = CBool(LFnt.lfWeight >= FW_BOLD)
      .Italic = CBool(LFnt.lfItalic)
      .Underline = CBool(LFnt.lfUnderline)
      .Strikethrough = CBool(LFnt.lfStrikeOut)
      .Size = CF_T.iPointSize / 10
    End With
    .ForeColor = CF_T.rgbColors
 
    ' Ausgabe starten
    .Cls
    If .ScaleWidth < .TextWidth(.FontName) Then
      .CurrentX = 5
      .CurrentY = 5
    Else
      .CurrentX = (.ScaleWidth - .TextWidth(.FontName)) / 2
      .CurrentY = (.ScaleHeight - .TextHeight(.FontName)) / 2
    End If
  End With
 
  Picture1.Print .FontName
End Sub