# Function EnumFontFamiliesA et Function GetDC (plantage)

• ### 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()

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é mardi 10 janvier 2012 07:14 attente de feedback
mercredi 4 janvier 2012 01:18

### Toutes les réponses

•

Avez-vous un message d’erreur avec plus de détails ? « Microsoft Excel a cessé de fonctionner » est assez général et il n’est pas de tout facile trouver une solution. Merci d’avance !

Cordialement,

Cipri

vendredi 6 janvier 2012 09:23