"Analyser" les polices disponibles

[dionys0s]

Bonjour tout le monde,

comme le stipule le titre, je cherche à analyser les polices disponibles dans Excel.

J'ai déjà ce qu'il me faut pour toutes les lister (cf. classeur joint). Ce que j'aimerais, c'est pouvoir exclure de cette liste toutes celles qui s'affichent mal (les polices chinoises ou bizarres par exemple...) et ne seraient donc pas "recommandées" à un utilisateur.

D'avance merci pour votre aide 🙂

(Il n'y a plus la possibilité d'utiliser les balises [Highlights=VBA] / [Highlights] ?)

 

[gosselien]

Bonjour,

edit: oups pas vu que tu avais déjà cela.. mais je laisse si qq un en a besoin 🙂
ceci devrait convenir pour afficher toutes les polices dispo 🙂

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

 

[job75]

Bonjour dionys0s, gosselien,

Je pense qu'il n'y a pas d'autre solution que de supprimer manuellement les polices qu'on ne veut pas garder.

Ce n'est pas la mer à boire !

A+

 

[job75]

Re,

Si vraiment on est un gros flemmard :

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

A+

 

[dionys0s]

Re,

Merci pour vos réponses.
Job, si je suis "un flemmard" c'est parce-que le code sera exécuté à partir d'une machine sur laquelle je ne sais pas quelles sont les polices disponibles. Et sur laquelle je n'ai pas la main.

 

[chris]

Bonjour

Excel utilise toutes les polices installées dans Windows : supprimer les polices peut gêner celui qui les utilise ailleurs que dans Excel et même mettre le souk dans Windows.
Je me souviens de suppressions qui se sont répercutées sur tous les affichages de Windows alors devenus illisibles.

On peut espérer que c'est mieux géré aujourd'hui mais comme des bugs datant du DOS réapparaissent de temps en temps, je ferais preuve de prudence...

Par ailleurs Arial unicode contient les caractères chinois, japonais etc...

 

[dionys0s]

Oui je ne comptais pas procéder par désinstallation de polices. Juste me résigner...

Par ailleurs, question qui n'apportera pas grand chose au schmilblick, mais pour satisfaire ma curiosité, dans la ligne de code suivante :

Application.CommandBars.FindControl(ID:=1728)

Quelqu'un saurait m'expliquer d'où sort le 1728 ? Qui l'a trouvé ? Où ? Quand ? Comment ? Pourquoi ? Quand est-ce qu'on mange ?
J'ai parcouru les constantes mso, impossible de trouver la valeur 1728... et ça me tarabuste.

La bonne fin de journée à tous.

 

[JCGL]

Bonjour à tous,

C'est le n° d'un Control.ID.

Voir la liste dans les fichiers joints.

A+ à tous

 

[dionys0s]

Bonjour tout le monde,

JCGL, je ne trouve pas le fichier joint...

 

[JCGL]

Bonjour à tous,

Essaye encore...

A+ à tous

 

[dionys0s]

Re,

je promets elle n'y étai pas... merci beaucoup.