Function EnumFontFamiliesA et Function GetDC (plantage)

Question

Bonjour à tous.

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

Mercie de votre intérêt.

Pierre

 

Answer 1

Bonjour Pierre

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

Si vous nous mettiez un bout de code, on pourrait vérifier si c'est vrai aussi sur d'autres machines et éventuellement d'avoir un code d'erreur.

---

A+

Answer 2

Bonjour, Archampi,

 

Est-ce que vous avez résolu votre problème ? Sinon, pouvez-vous svp nous montrer votre code et/ou le message d’erreur comme Geo vous a demandé ?

 

Merci de tenir la communauté informée sur la suite de vos démarches.

 

Cordialement,

 

Cipri

---

 

Ciprian DUDUIALA, MSFT  
•Nous vous prions de considérer que dans le cadre de ce forum on n’offre pas de support technique et aucune garantie de la part de Microsoft ne peut être offerte.

Answer 3

Merci de vous intéresser encore à ce problème.

 

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