LES POLICES ET EXCEL

Cette macro liste les polices disponibles dans la feuille active (Colonne A)

Const Code1 = "558BEC8B4D1433D28B450883C01CEB02424080380075F9660351" &
"02B801000000426689510266FF015DC210"

Const Code2 = "558BEC53568B551433C00FBFF08B4D088B5A0403DE408A4C311C" &
"0FBF720284C9880C3375E566014202B8010000005E5B5DC210"

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

Sub GetFontNames()
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)
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

Application.ScreenUpdating = False
With Range("A1", Cells(Fonts.Count, 1))
.Value = Application.Transpose(FontNames)
.Sort [A1]
End With
End Sub

Cette macro liste les polices disponibles dans un nouveau classeur avec le nom de la police et un exemple

C'est une belle macro (rapide) de Laurent Longre

Sub Police()
Dim Arr, I As Integer

Application.ScreenUpdating = False
Workbooks.Add

With Application.CommandBars.FindControl(ID:=1728)
ReDim Arr(1 To .ListCount, 1 To 1)

For I = 1 To UBound(Arr)
Arr(I, 1) = .List(I)
Cells(I, 2).Font.Name = Arr(I, 1)
Next I

End With

With Range("A1").Resize(I - 1)
.Value = Arr
.Offset(0, 1) = "Exemple de la police"
.Font.Size = 12
End With
Columns("A:B").AutoFit
End Sub

Une autre macro avec simplement un exemple dans un nouveau classeur

Sub ListePolice()
Dim I As Integer
Application.ScreenUpdating = False

Workbooks.Add

With Application.CommandBars.FindControl(ID:=1728)
For I = 1 To .ListCount
Cells(I, 1).Font.Name = .List(I)
Next I
End With

Range("A1").Resize(I - 1) = "FURTIVE, les cannes Pascal Cognard !!!"
Columns(1).AutoFit
End Sub

Une dernière de Chip Pearson qui prend ses infos directement à la source

Sub ListePolices()
Dim N As Integer
Sheets.Add

With Application.CommandBars.FindControl(ID:=1728)
For N = 1 To .ListCount
Cells(N, 1).Value = "Voici mon texte"
Cells(N, 1).Font.Name = .List(N)
Cells(N, 1).Font.Size = 12
Next N
End With
Cells(1, 1).EntireColumn.AutoFit
End Sub

[top]