VBA : parcourir les polices

[dionys0s]

Bonjour le forum

j'aurais souhaité savoir s'il était possible de parcourir les polices disponibles dans Excel, et d'obtenir leur nom.

D'avance merci pour votre aide ^^

 

[Victor21]

Re : VBA : parcourir les polices

Bonjour dionys0s.

Pour parcourir les polices disponibles, il suffit de cliquer sur la liste déroulante à droite du nom de la police dans le ruban.

Pour lister toutes les polices disponibles dans une feuille :

Sub ListePolices()
'd'après Chip Pearson, mpep
Dim N As Integer
  Sheets.Add
  With Application.CommandBars.FindControl(ID:=1728)
    For N = 1 To .ListCount
        Cells(N, 1).Value = .List(N)
        Cells(N, 1).Font.Name = .List(N)
        Cells(N, 1).Font.Size = 12
    Next N
  End With
  Cells(1, 1).EntireColumn.AutoFit
End Sub

 

[dionys0s]

Re : VBA : parcourir les polices

Re,
Bonjour Patrick

Superbe ! Je cherchais une solution VBA effectivement. Je n'avais pas pensé à taper ma recherche en anglais dans Google. Je devrais prendre ce réflexe.

Bonne après-midi 🙂

 

[Staple1600]

Re : VBA : parcourir les polices

Bonsoir à tous


Un petit complément de la maison mère
Macros to generate lists of available fonts in Word

PS: Normalement ce vaut pour Word, vaut pour Excel niveau police, non ?
L'avantage avec celle dans Word c'est qu'on a un échantillon visuel de la police

Dans le temps il y a Macro7.dot , mais cela c'était avant 😉
Ce lien n'existe plus

 

[JCGL]

Re : VBA : parcourir les polices

Bonjour à tous,
Salut les amis,

En reprenant le code l'ami Patrick et de Chip PEARSON et en ajoutant les lettres minuscules et majuscules et les chiffres :

Option Explicit

Sub ListePolices()    'd'après Chip Pearson, mpep
    Dim N%
    ActiveWindow.DisplayGridlines = False
    With Application.CommandBars.FindControl(ID:=1728)
        Cells.Clear
        With Cells(1, 1).Resize(, 2)
            .Value = [{"Polices Disponibles", "Exemples"}]
            .Font.Bold = True
            .Interior.ColorIndex = 15
            .EntireColumn.AutoFit
            With .Borders
                .LineStyle = 1
                .Weight = 2
            End With
        End With
        For N = 1 To .ListCount
            Cells(N + 1, 1).Value = .List(N)
            Cells(N + 1, 2) = "abcdefghijklmnopqrstuvwxyz  ABCDEFGHIJKLMNOPQRSTUVWXYZ  1234567890"
            Cells(N + 1, 2).Font.Name = .List(N)
        Next N
    End With
    With Columns("A:B")
        .Font.Size = 12
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
    Cells(1, 1).Select
End Sub

A+ à tous