none
Function EnumFontFamiliesA et Function GetDC (plantage) RRS feed

  • Discussion générale

  • Bonjour à tous.

    Pourquoi la fonction EnumFontFamiliesA et/ou GetDC plante dans VBA Excel 2010 alors que ça fonctionne très bien dans 2007 ?

    Voici le code qui fonctionne en Excel 2007

    Dans la partie déclaration de Module1:

     

    Option Explicit
    
    Const Code1 = "558BEC8B4D1433D28B450883C01CEB02424080380075F966035102B801000000426689510266FF015DC210"
    Const Code2 = "558BEC53568B551433C00FBFF08B4D088B5A0403DE408A4C311C0FBF720284C9880C3375E566014202B8010000005E5B5DC210"
    
    Type SFont
      Count As Integer
      Length As Integer
      Str As String
    End Type
    
    Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    
    Declare Function EnumFontFamiliesA Lib "gdi32" _
      (ByVal hdc As Long, ByVal lpFaceName As Long, _
      ByVal lpFontFunc As String, Fonts As SFont) As Long
    
    
    


    et cette procédure dans le même Module1:

     

    Public Sub GetFontNames(FontList() As Variant)
    Dim HexDec
    Dim CallBack1 As String, CallBack2 As String
    Dim Fonts As SFont
    Dim FontNames() As String
    Dim i As Integer, j As Integer, k As Integer
    
    HexDec = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, 10, 11, 12, 13, 14, 15)
    
    For i = 1 To Len(Code1) Step 2
        CallBack1 = CallBack1 & Chr(HexDec(Asc(Mid(Code1, i, 1)) - 48) * 16 + HexDec(Asc(Mid(Code1, i + 1, 1)) - 48))
    Next i
    
    For i = 1 To Len(Code2) Step 2
        CallBack2 = CallBack2 & Chr(HexDec(Asc(Mid(Code2, i, 1)) - 48) * 16 + HexDec(Asc(Mid(Code2, i + 1, 1)) - 48))
    Next i
    
    EnumFontFamiliesA GetDC(0), 0, CallBack1, Fonts
    Fonts.Str = Space(Fonts.Length)
    Fonts.Length = 0
    EnumFontFamiliesA GetDC(0), 0, CallBack2, Fonts
    
    ReDim FontNames(1 To Fonts.Count)
    ReDim FontList(1 To Fonts.Count)
    j = 1
    For i = 1 To Fonts.Count
        k = InStr(j, Fonts.Str, Chr(0))
        FontNames(i) = Mid(Fonts.Str, j, k - j)
        j = k + 1
    Next
    
    For i = 1 To Fonts.Count
        FontList(i) = FontNames(i)
    Next i
    
    End Sub
    
    


    Dans le UserForm1, Un ComboBox "ComboPolices" et un CommandButton "CommandButton1".

     

    et ce code dans le UserForm1:

     

    Option Explicit
    
    Private Sub CommandButton1_Click()
    
    Unload Me
    
    End Sub
    
    Private Sub UserForm_Initialize()
    Dim FontList() As Variant
    
    Call GetFontNames(FontList())
    ComboPolices.List() = FontList()
    ComboPolices.Text = "Arial"
    
    End Sub
    
    
    


    Ceci donne le résultat recherché:

     

    Or, si j'essaie de faire rouler ce code dans Excel 2010 Windows m'avise que Microsoft Excel a cessé de fonctionner.

    L'erreur survient à l'exécution de la ligne suivante.

    EnumFontFamiliesA GetDC(0), 0, CallBack1, Fonts
    

    Si je pouvais trouver une autre façon de faire la même chose qui soit compatible avec les deux versions ce serait extra!

    Merci de votre aide.

    Pierre

    • Type modifié Ciprian Duduiala mardi 10 janvier 2012 07:14 attente de feedback
    mercredi 4 janvier 2012 01:18

Toutes les réponses