none
verfügbare Schriftgrößen aller installierten Schriftarten in ComboBox laden

    Frage

  • Hallo,

    ich bastle für Access 2003 einen RTF Editor. Da ich die Benutzung des StandartFontDialogs nicht schön finde möchte ich 2 ComboBoxen anbieten, eine mit den installierten Schriftarten und eine zweite mit den für die ausgewählte Schriftart verfügbaren Schriftgrößen.

    Die Schriftarten bekomme ich geladen und stehen auch in der ComboBox zur Verfügung. Das Ändern der Schriftarten in dem RTF Feld funktioniert einwandfrei.

    Meine Frage ist nun, wie mache ich das mit den Schriftgrößen. Wenn ein Text markiert ist soll die Schriftart erkannt werden und in der 2.ComboBox die für die Schriftart verfügbaren Schriftgrößen geladen werden. Gibt es dafür schon fertige Lösungen für Access 2003 oder wie würdet Ihr das Problem angehen und lösen?

    Vielen Dank im Voraus.

    • Typ geändert Thorsten Dörfler Montag, 30. August 2010 11:58 Frage
    • Verschoben Thorsten Dörfler Montag, 30. August 2010 11:58 Access VBA (aus:Visual Basic 6.0 - Interoperabilität und Upgrade)
    Montag, 30. August 2010 11:53

Antworten

  • Hi,

     

    Ok, da ich keinen fertigen Code rumfahren habe, aber mich die Umsetzung - trotz Zeitmangels! ;-) - interessierte:

    Bitte die ganzen API-Deklarationen aus dem vbArchiv-Artikel nehmen. Plus diese:

     

    Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long

     

    Dann die folgenden Routinen, die die aus vbArchiv ersetzen:

     

    Function GetFontSizes(Optional ByVal sFontname As String = "Small Fonts") As Collection
      Dim LF As LOGFONT
      Dim hDC As Long
      Dim ret As Long
      Dim colSizes As New Collection
      Dim itm As Variant
    
      LF.lfCharSet = DEFAULT_CHARSET
      Mid(LF.lfFaceName, 1, Len(sFontname)) = sFontname
      hDC = GetDC(0)
      ret = EnumFontFamiliesEx(hDC, LF, AddressOf FntEnumProc, ObjPtr(colSizes), 0&)
      
      For Each itm In colSizes
        Debug.Print itm
      Next itm
      
      Set GetFontSizes = colSizes
      Set colSizes = Nothing
    End Function
    
    Public Function FntEnumProc(ByVal FontDesc As Long, ByVal TMetric As Long, _
                  ByVal FontType As Long, ByVal lParam As Long) As Long
      Dim LFont As ENUMLOGFONTEX, TM As TEXTMETRIC, NTM As NEWTEXTMETRIC
      Dim colSizes As Collection
      
      MoveMemory LFont, ByVal FontDesc, Len(LFont)
      Set colSizes = ObjectFromPointer(lParam)
      
      If CBool(FontType And TRUETYPE_FONTTYPE) = False Then
        MoveMemory TM, ByVal TMetric, Len(TM)
        colSizes.Add Round((TM.tmHeight - TM.tmInternalLeading) * 15 / 20)
      Else
        MoveMemory NTM, ByVal TMetric, Len(NTM)
        colSizes.Add Round((NTM.tmHeight - NTM.tmInternalLeading) * 15 / 20)
      End If
    
      
      FntEnumProc = 1
    End Function
    
    Function ObjectFromPointer(lPtr As Long) As Object
      Dim oTemp As Object
      MoveMemory oTemp, lPtr, 4
      Set ObjectFromPointer = oTemp
      MoveMemory oTemp, 0&, 4
    End Function
    

     

    Einfach

    GetFontSizes
    

    aufrufen.

    Ciao, Sascha

     


    Sascha Trowitzsch
    Dienstag, 31. August 2010 11:06
  • Also ich denke mal, ich stelle hier mal den Code mit dem die installierten Schriftarten in eine ComboBox geladen werden.

    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
    
    
    
    Private Sub Form_Load()
    
      Call EnumFontToControl("FormName", "NameComboBox") 
        
    End Sub
    
    Ist ja nicht gerade unwichtig für Euch
    Dienstag, 31. August 2010 10:56

Alle Antworten

  • Hallo vba_newsbie,

    ich habe Deine Frage ins neue Access Forum verschoben, da ich denke, dass sie dort besser beantwortet werden kann.


    Thorsten Dörfler
    Microsoft MVP Visual Basic
    vb-faq.de
    Montag, 30. August 2010 12:01
  • Hallo Thorsten Dörfler,

     

    danke schön.

     

    Gruß

    Montag, 30. August 2010 12:09
  • Hallo,
     
    vba_newsbie:
     
    > ich bastle für Access 2003 einen RTF Editor. Da ich die Benutzung des StandartFontDialogs nicht schön finde möchte ich 2 ComboBoxen anbieten,
    > eine mit den installierten Schriftarten und eine zweite mit den für die ausgewählte Schriftart verfügbaren Schriftgrößen.
    >
    > Die Schriftarten bekomme ich geladen und stehen auch in der ComboBox zur Verfügung. Das Ändern der Schriftarten in dem RTF Feld funktioniert
    > einwandfrei.
    >
    > Meine Frage ist nun, wie mache ich das mit den Schriftgrößen. Wenn ein Text markiert ist soll die Schriftart erkannt werden und in der 2.ComboBox die
    > für die Schriftart verfügbaren Schriftgrößen geladen werden. Gibt es dafür schon fertige Lösungen für Access 2003 oder wie würdet Ihr das Problem
    > angehen und lösen?
     
    schau mal hier
     
     
    Gruß - Mark
     
    Montag, 30. August 2010 13:31
  • Hallo Mark,

     

    danke für den Link, aber er hilft mir nicht weiter.

    Montag, 30. August 2010 13:46
  • Hallo,
     
    vba_newsbie:
     
    > danke für den Link, aber er hilft mir nicht weiter.
     
    könntest Du das noch erläutern? Dort finden sich gleich mehrere
    Lösungen, wie man das, was Du machen willst (so ich es verstanden
    habe), lösen kann. Wo habe ich Dich falsch verstanden?
     
    Gruss - Mark
     
    Montag, 30. August 2010 14:29
  • Hallo Mark,

    >>> http://office.microsoft.com/de-de/access-help/einfugen-oder-hinzufugen-eines-rich-text-felds-HA010014097.aspx?pid=CH100645681031

    zeigt wie ich ein RTF-Feld in Access 2007 eingefügt wird. Ich habe bereits in Access 2003 ein RTF-Feld.

     

    >>> http://www.lebans.com/richtext.htm

    zeigt Bsp. Datenbanken fürs RTF-Feld. Das ist die Grundlage meines RTF-Editors.

     

    >>>  http://www.fmsinc.com/

    zeigt eine kommerzielle Lösung. Die werden mir sicher keinen Support geben wie ich mein Problem lösen kann

     

    >>> http://access.primary.at/downloads.htm

    Hier finde ich garnix zum Thema RTF

     

    Mark, ich suche eine Möglichkeit wie ich für die installierten Schriftarten die untersützten Schriftgrößen in eine ComboBox laden kann.

     

    Gruss - Frank

    Montag, 30. August 2010 14:59
  • Hallo,
     
    vba_newsbie:
     
    > ich suche eine Möglichkeit wie ich für die installierten Schriftarten
    > die untersützten Schriftgrößen in eine ComboBox laden kann.
     
    na, da wird es mir doch gleich klarer! ;-)
     
    Ich denke, da wirst Du in Access API brauchen (Word hat glaube ich
    Application.FontNames, aber das nutzt Dir nix).
     
    Ich habe es nicht ausprobiert, aber schau mal
     
      (für die etwas bessere Erläuterung des Prinzips)
     
      (für den Code)
     
    an.
     
    Gruß - Mark
     
    Montag, 30. August 2010 15:12
  • Hallo Mark,

    danke für Deine Hinweise. Setze mich nachher gleich hin und probiere es aus.

    Dienstag, 31. August 2010 06:49
  • Hallo Mark,

     

    ich bekomme es nicht hin den C Code nach VBA zu konvertieren:

    int EnumFontSizes(char *fontname)
    
    {
    
      LOGFONT logfont;
    
    
    ZeroMemory(&logfont, sizeof logfont);
    
    
    logfont.lfHeight = 0;
    logfont.lfCharSet = DEFAULT_CHARSET;
    logfont.lfPitchAndFamily = FIXED_PITCH | FF_DONTCARE;
    lstrcpy(logfont.lfFaceName, fontname);
    
    
    EnumFontFamiliesEx(hdc, &logfont, (FONTENUMPROC)FontSizesProc, 0, 0);
    
    
    return 0;
    }
    
    
    
    
    int CALLBACK FontSizesProc(
      LOGFONT *plf,   /* pointer to logical-font data */
      TEXTMETRIC *ptm,  /* pointer to physical-font data */
      DWORD FontType,  /* font type */
      LPARAM lParam   /* pointer to application-defined data */
      )
    {
      static int truetypesize[] = { 8, 9, 10, 11, 12, 14, 16, 18, 20, 
          22, 24, 26, 28, 36, 48, 72 };
    
    
    int i;
    
    
    if(FontType != TRUETYPE_FONTTYPE)
    {
    int logsize = ptm->tmHeight - ptm->tmInternalLeading;
    long pointsize = MulDiv(logsize, 72, GetDeviceCaps(hdc, LOGPIXELSY));
    
    
    for(i = 0; i < cursize; i++)
    if(currentsizes[i] == pointsize) return 1;
    
    
    printf("%d ", pointsize);
    
    currentsizes[cursize] = pointsize;
    if(++cursize == 200) return 0;
    
    return 1;
    }
    else
    {
    
    
    for(i = 0; i < (sizeof(truetypesize) / sizeof(truetypesize[0])); i++)
    {
    printf("%d ", truetypesize[i]);
    }
    
    
    return 0;
    }
    
    
    }
    
    
    Kannst Du mir da ein wenig unter die Arme greifen?

    Dienstag, 31. August 2010 08:34
  • Hallo,
     
    vba_newsbie:
     
    > ich bekomme es nicht hin den C Code nach VBA zu konvertieren:
     
    bevor ich das probiere, würde ich eher den VB-Code aus dem zweiten
    Link nehmen und ggf. etwas anpassen. Spricht da etwas dagegen?
     
    Gruss - Mark
     
    Dienstag, 31. August 2010 10:03
  • Hi,

    da spricht natürlich nichts dagegen. Aber ich muss ehrlich zugeben, dass ich damit ganz schön überfordert bin.

     

    Gruss

    Dienstag, 31. August 2010 10:08
  • Hi,

     

    Die Arbeit würde ich mir sparen.

    Du kannst natürlich den Code auf vbArchiv nehmen, auf den Mark gelinkt hat, und statt tmAveCharWidth die Höhe (=Schriftgröße) auswerten (TM.tmHeight - TM.tmInternalLeading).

    Nur hat das ausschließlich für Fixed size fonts Relevanz und nicht für True Type Fonts. Und nur letztere würde ich dem User für das RTF anbieten.

    Die Callback-Funktion gibt für TrueTypes nämlich immer den gleichen Wert für TM-tmHeight zurück. ;-) Einfacher Grund: True Type Fonts können in beliebiger Größe gerendert werden!

    Du kannst es also gleich bei deiner fix bestückten Größen-Combo belassen.

     

    Ciao, Sascha


    Sascha Trowitzsch
    Dienstag, 31. August 2010 10:12
  • Hallo, Frank,

     

    gib mir einen Moment, dann baue ich mal ein Beispiel.

     

    Gruß - Mark

    Dienstag, 31. August 2010 10:21
  • Hi, Sascha,

     

    ja, das steht ja auch in der von mir gelinkten Seite.

     

    Trotzdem scheint mir die Umsetzung nicht ganz trivial (für Fixed size fonts).

     

    Gruß - Mark

    Dienstag, 31. August 2010 10:24
  • Hi Mark

    super, wäre genial wenn Du mir ein kleines Beispiel bauen könntest.

     

    Hi Sascha,

     

    nur TrueType anzubieten ist nicht optimal oder? Das bekomme ich auch hin, ist so aber nicht gedacht.

     

    P.S. Danke Euch beiden für Eure Unterstützung

    Gruß

    • Bearbeitet vba_newsbie Dienstag, 31. August 2010 10:29 .
    Dienstag, 31. August 2010 10:27
  • Naja, ich kann das gerne in VB für die Fixed Fonts umsetzen.

    Aber erst, wenn sich vba_newbie sicher ist, dass er diese auch wirklich benötigt - was ich, wie gesagt, für überflüssig halte. Sieht doch sch... aus?!

    Ciao, Sascha

     


    Sascha Trowitzsch
    Dienstag, 31. August 2010 10:28
  • Naja, ich kann das gerne in VB für die Fixed Fonts umsetzen.

    Aber erst, wenn sich vba_newbie sicher ist, dass er diese auch wirklich benötigt - was ich, wie gesagt, für überflüssig halte. Sieht doch sch... aus?!

    Ciao, Sascha

     


    Sascha Trowitzsch
    ja, schauen wir mal ob ich das richtig verstanden habe. Es gibt ja verschiedene "Gruppen" z.b. TrueTypes oder VectorTypes. Und du würdest mir das für die Fixed Fonts umsetzen? Die Vectortypen sind ja eh in jeder Größe verfügbar, oder?
    Dienstag, 31. August 2010 10:35
  • wir wollen uns nicht streiten, wer das nun umsetzen darf, Sascha.

    Wenn Du gerade Zeit hast, mach nur! ;-)

    Schöne Grüße - Mark

    Dienstag, 31. August 2010 10:45
  • Also ich denke mal, ich stelle hier mal den Code mit dem die installierten Schriftarten in eine ComboBox geladen werden.

    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
    
    
    
    Private Sub Form_Load()
    
      Call EnumFontToControl("FormName", "NameComboBox") 
        
    End Sub
    
    Ist ja nicht gerade unwichtig für Euch
    Dienstag, 31. August 2010 10:56
  • Hi,

     

    Ok, da ich keinen fertigen Code rumfahren habe, aber mich die Umsetzung - trotz Zeitmangels! ;-) - interessierte:

    Bitte die ganzen API-Deklarationen aus dem vbArchiv-Artikel nehmen. Plus diese:

     

    Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long

     

    Dann die folgenden Routinen, die die aus vbArchiv ersetzen:

     

    Function GetFontSizes(Optional ByVal sFontname As String = "Small Fonts") As Collection
      Dim LF As LOGFONT
      Dim hDC As Long
      Dim ret As Long
      Dim colSizes As New Collection
      Dim itm As Variant
    
      LF.lfCharSet = DEFAULT_CHARSET
      Mid(LF.lfFaceName, 1, Len(sFontname)) = sFontname
      hDC = GetDC(0)
      ret = EnumFontFamiliesEx(hDC, LF, AddressOf FntEnumProc, ObjPtr(colSizes), 0&)
      
      For Each itm In colSizes
        Debug.Print itm
      Next itm
      
      Set GetFontSizes = colSizes
      Set colSizes = Nothing
    End Function
    
    Public Function FntEnumProc(ByVal FontDesc As Long, ByVal TMetric As Long, _
                  ByVal FontType As Long, ByVal lParam As Long) As Long
      Dim LFont As ENUMLOGFONTEX, TM As TEXTMETRIC, NTM As NEWTEXTMETRIC
      Dim colSizes As Collection
      
      MoveMemory LFont, ByVal FontDesc, Len(LFont)
      Set colSizes = ObjectFromPointer(lParam)
      
      If CBool(FontType And TRUETYPE_FONTTYPE) = False Then
        MoveMemory TM, ByVal TMetric, Len(TM)
        colSizes.Add Round((TM.tmHeight - TM.tmInternalLeading) * 15 / 20)
      Else
        MoveMemory NTM, ByVal TMetric, Len(NTM)
        colSizes.Add Round((NTM.tmHeight - NTM.tmInternalLeading) * 15 / 20)
      End If
    
      
      FntEnumProc = 1
    End Function
    
    Function ObjectFromPointer(lPtr As Long) As Object
      Dim oTemp As Object
      MoveMemory oTemp, lPtr, 4
      Set ObjectFromPointer = oTemp
      MoveMemory oTemp, 0&, 4
    End Function
    

     

    Einfach

    GetFontSizes
    

    aufrufen.

    Ciao, Sascha

     


    Sascha Trowitzsch
    Dienstag, 31. August 2010 11:06
  • Hallo Sascha,

    erstmal danke das Du mir auf die schnelle so gut weiter geholfen hast.

    Beim Aufruf von GetFontSizes kommt 2,3,4,5,6,7

    Heisst das nun, das das die Schnittmenge ist die ALLE Schriftarten als Schriftgrößen akzeptieren?

    Gruß

     

    Dienstag, 31. August 2010 11:56
  • Habe noch ein Verständigungsproblem:

    Wo holt er die Schriftgrößen her? Denn, wenn ich z.b. aufrufe GetFontSizes("Arial") wird 34 mal die 24 aufgerufen

    Das macht die Funktion hier mit, oder?

    MoveMemory TM, ByVal TMetric, Len(TM)
        colSizes.Add Round((TM.tmHeight - TM.tmInternalLeading) * 15 / 20)

    Was ich daraus lese ist das die Schriftart Arial 34 Schriftgrößen unterstützt, u.a. die 24 oder?

     

     

    Dienstag, 31. August 2010 12:37
  • Ok, das mit der Übergabe des Schriftartennamens an die Prozedur hast du ja dann geschnallt. ;-)

     

    Aber aus dem Verlauf der Diskussion sollte doch hervorgegangen sein, dass man die Funktion für TrueType-Fonts nicht benötigt, da diese in beliebiger Größe gerendert werden können. Die haben keine eingebauten Größen; du kannst nehmen, was du willst, ´von mir aus auch 12 komma 4.

    Deine erwähnten Vektor-Fonts sind eben True Type und Open Type Schriften - also fast alle, die man unter Windows benutzt. Schau doch mal in deinen Windows-Ordner c:\windows\fonts: Alle, die so ein O- oder TT-Icon haben, sind Vektor-Fonts. Nur für die mit dem roten Icon braucht man die Funktion, wozu eben z.B. "Small Fonts" gehört.

    Du müsstest die rausfiltern. Ob ein Font Fixed ist (...die roten), das steht in der LOGFONT-Variablen

    lpNLF.lfPitchAndFamily

    in deinem wahrscheinlich von AccessOMania stammenden Code.

    Ciao, Sascha

     


    Sascha Trowitzsch
    Dienstag, 31. August 2010 14:32
  • Es ist also noch nicht (ganz) Hopfen und malz verloren. Jupp, nun ist mir einiges klarer.....

    Trotzdem verstehe ich nicht warum beim Aufruf von GetFontSizes Arial 34 mal die 24 ausgegeben wird und bei Times New Rom und Courier kommt einmal die 24. Da der Editor ja weitesgehend PC unabhängig sein soll,muss ich also von dem markierten Text die Schriftart auslesen. Prüfen ob TrueType. Wenn ja kann jede erdenkliche Schriftgröße genutzt werden (zB 12,5).

    Wenn nein, es sich also um eine "Small Font" handelt, muss ich die von Dir geschriebene Funktionnutzen um die verfügbaren Schriftarten rauszulesen. Sehe ich das so Richtig?

    Auch bei den Small-Fonts wird jeweils nur eine 24 ausgegeben. Damit kann man ja nun auch nicht wirklich etwas anfangen.

    • Bearbeitet vba_newsbie Dienstag, 31. August 2010 15:08 Erkenntnis
    Dienstag, 31. August 2010 14:45
  • ach ich habe nichts von AccessOMania direkt übernommen :-)
    Dienstag, 31. August 2010 15:00
  • Erster Teil: Ja, siehst du richtig.

    Zweiter:

    Auch bei den Small-Fonts wird jeweils nur eine 24 ausgegeben. Damit kann man ja nun auch nicht wirklich etwas anfangen.

    Ich auch nicht.

    Oben hast du noch hingeschrieben, dass bei Aufruf mit "Small Fonts" (...was als Vorgabewert in der Funktionszeile für den Parameter sFontname steht) diese Werte rauskamen:

    2,3,4,5,6,7

    Und das ist auch bei mir so und korrekt. Wo gibt's noch ein Problem?

     

    Ciao, Sascha

     

     



    Sascha Trowitzsch
    Dienstag, 31. August 2010 15:32
  • Hallo
    AFAIR gibt es keine "unterstützten" Schriftgrössen für TrueType Fonts. Diese können beliebige Schriftgrössen annehmen, selbst 12.3 oder 10.2 wird unterstützt.
    Wenn es nicht TrueType Schriften sind, dann wird es schwieriger. Dann wirst Du wohl eine Font API Funktion suchen müssen, welche Dir diese zurückgibt. Es stellt sich allerdings die Frage, ob Du mit solchen Schriftarten überhaupt noch arbeiten musst.
     
    Zu Deiner Frage noch was anderes: Dir ist bewusst, dass die RTF Felder in A2007 nicht mehr RTF sind, sondern als RFT im HTML Format abgelegt werden? Du solltest Dir Gedanken darüber machen, ob Du hier nicht vielleicht auf einen Zug aufspringst, der in eine Sackgasse einfährt. Ich würde Dir empfehlen vorgängig eine Migration auf eine neuere Version vorzunehmen und gleich die neuen Funktionalitäten zu verwenden, die diese für RFT Felder anbieten.
     
    Gruss
    Henry
     
    "vba_newsbie" <=?utf-8?B?dmJhX25ld3NiaWU=?=> wrote in message news:594c0746-0f97-4ffd-b4d7-947eea1d4e12...

    Mark, ich suche eine Möglichkeit wie ich für die installierten Schriftarten die untersützten Schriftgrößen in eine ComboBox laden kann.

     


    [MVP Office Access]
    Mittwoch, 1. September 2010 06:16
  • Hallo Mark
    eine alternative wäre der ComDlg32 Ersatz den es beim www.dbdev.org im Download Bereich gibt. Nur die Fontgrössen listet auch dieser nicht aus.
    Gruss
    Henry
    "Mark Doerbandt" <=?utf-8?B?TWFyayBEb2VyYmFuZHQ=?=> wrote in message news:39cd89ff-1c9c-4245-aa4a-9087080eb771...
    Hallo,
     
    vba_newsbie:
     
    > ich bekomme es nicht hin den C Code nach VBA zu konvertieren:
     
    bevor ich das probiere, würde ich eher den VB-Code aus dem zweiten
    Link nehmen und ggf. etwas anpassen. Spricht da etwas dagegen?
     
    Gruss - Mark
     

    [MVP Office Access]
    Mittwoch, 1. September 2010 06:19
  • Hallo Henry Habermann,

    danke für Deine Hinweise.

    1.) Ich brauche die Schriftgrößen zu allen installierten Schriftarten. Da die Editor ja PC unabhängig sein soll. Und ich die Schriftarten nicht stur vorgeben möchte.

    2.) Access 2010, gut und schön, und das mit HTML ist super. Aber ich habe kein Access 2010 und werde es mir nicht zu legen. Access 2003 ist das System was ich habe und nutze. Außerdem ist es am meisten verbreitet.

    Mittwoch, 1. September 2010 08:30
  • So, ich klinke mich hier mal ein!

    Der Wert für die Schriftgröße (FontSize) wird wie folgt ermittelt.

    In einer Schleife wird dieser Wert gesetzt und ist dieser größer als der vorherige Wert wird er in die Liste übernommen. Wenn nicht, dann ist diese Schriftgröße für die Schriftart nicht vorhanden.

     Dim intM As Integer
     Dim FontSize As Double
    
     FntObj.FontName = "Arial"
     Label1.FontName = FntObj.FontName
     List1.Clear
     For intM = 5 To 60
      FntObj.FontSize = intM
      If FntObj.FontSize > FontSize Then
       FontSize = FntObj.FontSize
       List1.AddItem FntObj.FontSize
      End If
     Next
    
    
    Probiers mal aus.
    Mittwoch, 1. September 2010 08:59
  • Hi,

    OT: Was geht hier genau schief? Die Beiträge von Henry und Dennis sehen so aus, als hätten sie die oberen Antworten nicht gelesen - Bridge? Kann es sein, dass die Bridge die Posts nicht alle abgeholt hat?

    Ciao, Sascha

     


    Sascha Trowitzsch
    Mittwoch, 1. September 2010 09:37
  • Danke Sascha, du sprichst mir aus der Seele.
    Mittwoch, 1. September 2010 11:20
  • Ja, Bridge. Kann durchaus sein. Mir scheinen auch einige Postings zu fehlen. Vielleicht was beim Verschieben des Threads in dieses Forum schiefgelaufen. Mal schauen, wie sich das weiterentwickelt.
    Dieses hier kam aber an.
     
    Gruss
    Henry
    "Sascha Trowitzsch" <=?utf-8?B?U2FzY2hhIFRyb3dpdHpzY2g=?=> wrote in message news:bdccc549-7ccf-465f-b8be-a65e92a239b6...

    Hi,

    OT: Was geht hier genau schief? Die Beiträge von Henry und Dennis sehen so aus, als hätten sie die oberen Antworten nicht gelesen - Bridge? Kann es sein, dass die Bridge die Posts nicht alle abgeholt hat?

    Ciao, Sascha

     


    Sascha Trowitzsch

    [MVP Office Access]
    Donnerstag, 2. September 2010 11:39
  • @ Sascha

     

    DANKE nochmals für Deine Hilfe. Es funktioniert!

    Dienstag, 21. September 2010 12:02