Moin Moin,
Ich habe ein RTF-Feld in meinem Formular. Um die Gestaltung für den User individueller zu gestalten hatte ich mir gedacht, dass ich dem User 2 ListBoxen anbiete eine für die Schriftart und die andere für die Schriftgröße.
Schriftart:
Option Compare Database
Option Explicit
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
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
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
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 Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetFocus Lib "USER32" () As Long
'Declare variables required for this module.
Dim WrkCtrl As Control 'will hold the ComboBox or ListBox Control to be filled
Dim FontArray() As String 'The Array that will hold all the Fonts (needed for sorting)
Dim FntInc As Integer 'The FontArray element incremental counter.
Private Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, LParam As Long) As Long
Dim FaceName As String
'convert the returned string to Unicode
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
'Dimension the FontArray array variable to hold the next Font Name.
ReDim Preserve FontArray(FntInc)
'Place the Font name into the newly dimensioned Array element.
FontArray(FntInc) = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
'continue enumeration
EnumFontFamProc = 1
'Increment the Array Element Counter.
FntInc = UBound(FontArray) + 1
End Function
Public Sub EnumFontToControl(ByVal Frm As String, ByVal Ctrl As String)
Dim LF As LOGFONT
Dim hdc As Long
Dim I As Integer
'Set the WrkCtrl Control variable to the passed
'control we want to fill wih Font Names. This
'control must be either a ComboBox or a ListBox.
Set WrkCtrl = Forms(Frm).Controls(Ctrl)
'Set the Row Source Type for the ComboBox or
'ListBox to "Value List".
WrkCtrl.RowSourceType = "Value List"
'Clear the current List (if any) within the
'control.
WrkCtrl.RowSource = ""
'Retrieve the DC handle of the ComboBox or ListBox
'to be filled. The GetHWND function is also used to
'get the DC.
hdc = GetDC(GetHWND(WrkCtrl))
'Enumerate the fonts
EnumFontFamiliesEx hdc, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
'Finished Enumeration. Release the DC.
ReleaseDC GetHWND(WrkCtrl), hdc
'Sort the FontArray string array.
Call QuickSortStringArray(FontArray(), 0, UBound(FontArray))
'Fill the Passed ComboBox or ListBox Conrol with the
'system Fonts found.
For I = 0 To UBound(FontArray)
WrkCtrl.AddItem Item:=FontArray(I)
Next I
'Free memory...
Set WrkCtrl = Nothing
FntInc = 0
Erase FontArray
End Sub
Public Function GetHWND(Ctrl As Control) As Long
'This function will get the Handle of a MS-Access
'Control.
'Set focus onto the Control we want to get the
'Handle from (this must be done)
Ctrl.SetFocus
'Use the API GetFocus Function to retrieve the
'Handle and return it.
GetHWND = GetFocus&()
End Function
Public Sub QuickSortStringArray(avarIn() As String, ByVal intLowBound As Integer, _
ByVal intHighBound As Integer)
'GENERAL SUB-PROCEDURE
'=====================
'Quicksorts the passed array of Strings
'avarIn() - array of Strings that gets sorted
'intLowBound - low bound of array
'intHighBound - high bound of array
'Declare Variables...
Dim intX As Integer, intY As Integer
Dim varMidBound As Variant, varTmp As Variant
'Trap Errors
On Error GoTo PROC_ERR
'If there is data to sort
If intHighBound > intLowBound Then
'Calculate the value of the middle array element
varMidBound = avarIn((intLowBound + intHighBound) \ 2)
intX = intLowBound
intY = intHighBound
'Split the array into halves
Do While intX <= intY
If avarIn(intX) >= varMidBound And avarIn(intY) <= varMidBound Then
varTmp = avarIn(intX)
avarIn(intX) = avarIn(intY)
avarIn(intY) = varTmp
intX = intX + 1
intY = intY - 1
Else
If avarIn(intX) < varMidBound Then
intX = intX + 1
End If
If avarIn(intY) > varMidBound Then
intY = intY - 1
End If
End If
Loop
'Sort the lower half of the array
QuickSortStringArray avarIn(), intLowBound, intY
'Sort the upper half of the array
QuickSortStringArray avarIn(), intX, intHighBound
End If
PROC_EXIT:
'Outta here
Exit Sub
PROC_ERR:
'Display the Error Trapped
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"QuickSortStringArray"
'Jump to...
Resume PROC_EXIT
End Sub
Die FontSize hatte ich manuell in die ListBox eingetragen, von 8-72. Wie ich aber mitbekam ist nicht jede Schriftgröße für jede Schriftart verfügbar. Wie kann ich die Schriftgrößen der installierten Schriftarten in die Listbox laden?
DANKE im vorraus.
Gruss
Horst