collapse

* Benutzer Info

 
 
Willkommen Gast. Bitte einloggen oder registrieren. Haben Sie Ihre Aktivierungs E-Mail übersehen?

* Wer ist Online

  • Punkt Gäste: 57
  • Punkt Versteckte: 0
  • Punkt Mitglieder: 1
  • Punkt Benutzer Online:

* Forenstatistik

  • stats Mitglieder insgesamt: 14070
  • stats Beiträge insgesamt: 67529
  • stats Themen insgesamt: 9099
  • stats Kategorien insgesamt: 5
  • stats Boards insgesamt: 17
  • stats Am meisten online: 415

Autor Thema: RTF-Feld Auswahl FontSize  (Gelesen 2488 mal)

Offline vba_unknow

  • Newbie
  • Beiträge: 1
RTF-Feld Auswahl FontSize
« am: August 18, 2010, 16:17:12 »
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