"Analyser" les polices disponibles

Option Explicit

Sub ListePolices()    ' toutes les polices avec un exemple
Dim i, x
Application.ScreenUpdating = False
Sheets.Add
With Application.CommandBars.FindControl(ID:=1728)
  For x = 1 To .ListCount
    Cells(x, 1).Value = "Mon tailleur est pauvre"
    Cells(x, 1).Font.name = .List(x)
    Cells(x, 2) = Cells(x, 1).Font.name
    Cells(x, 1).Font.Size = 12
  Next
End With
End Sub

Sub SupprimerPolices()
Dim t, exclu, ub As Byte, i&, x$, j As Byte, n&
With Wks4.[A1].CurrentRegion.Resize(, 3)
  .Columns(3) = ""
  t = .Value
  exclu = Array("Bookshelf*", "Marlett", "MS Reference Specialty", "MT*", "Webdings", "Wingdings*")
  ub = UBound(exclu)
  For i = 1 To UBound(t)
    x = t(i, 1)
    For j = 0 To ub
      If x Like exclu(j) Then t(i, 3) = " " '= 1 si on veut les voir
    Next
    x = UCase(Replace(Replace(Replace(Replace(Replace(x, " ", ""), ".", ""), ":", ""), "-", ""), "_", ""))
    For j = 48 To 57 'chiffres
      x = Replace(x, Chr(j), "")
    Next
    For j = 65 To 90 'lettres majuscules
      x = Replace(x, Chr(j), "")
    Next
    If x <> "" Then t(i, 3) = " " '= 1 si on veut les voir
  Next
  .Value = t
  On Error Resume Next
  With .Columns(3).SpecialCells(xlCellTypeConstants)
    n = .Count
    .EntireRow.Delete
  End With
End With
MsgBox n & " police(s) supprimée(s)..."
End Sub

Application.CommandBars.FindControl(ID:=1728)