Afficher toutes les polices installées (Word) à l’aide de VBA dans Microsoft Excel
Les macros ci-dessous afficheront une liste de toutes les polices installées. Remarque! Si plusieurs polices sont installées, la macro peut cesser de répondre en raison d’un manque de mémoire disponible.
Sub ShowInstalledFonts() Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer Dim stdFont As String fontSize = 0 fontSize = InputBox("Enter Sample Font Size Between 8 And 30", _ "Select Sample Font Size", 12) If fontSize = 0 Then Exit Sub If fontSize < 8 Then fontSize = 8 If fontSize > 30 Then fontSize = 30 Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728) If FontNamesCtrl Is Nothing Then Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _ msoBarFloating, False, True) Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728) End If Application.ScreenUpdating = False fontCount = FontNamesCtrl.ListCount Documents.Add stdFont = ActiveDocument.Paragraphs(1).Range.Font.Name ' add heading With ActiveDocument.Paragraphs(1).Range .Text = "Installed fonts:" End With LS 2 ' list font names and font example on every other line For i = 0 To FontNamesCtrl.ListCount - 1 fontName = FontNamesCtrl.List(i + 1) If i Mod 5 = 0 Then Application.StatusBar = "Listing font " & _ Format(i / (fontCount - 1), "0 %") & " " & _ fontName & "..." With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = fontName .Font.Name = stdFont End With LS 1 tFormula = "abcdefghijklmnopqrstuvwxyz" If Application.International(wdProductLanguageID) = 47 Then tFormula = tFormula & "æøå" End If tFormula = tFormula & UCase(tFormula) tFormula = tFormula & "1234567890" With ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range .Text = tFormula .Font.Name = fontName End With LS 2 Next i ActiveDocument.Content.Font.Size = fontSize Application.StatusBar = False If Not FontCmdBar Is Nothing Then FontCmdBar.Delete Set FontCmdBar = Nothing Set FontNamesCtrl = Nothing ActiveDocument.Saved = True Application.ScreenUpdating = True Application.ScreenRefresh End Sub Private Sub LS(lCount As Integer) ' adds lCount new paragraph(s) at the end of the document Dim i As Integer With ActiveDocument.Content For i = 1 To lCount .InsertParagraphAfter Next i End With End Sub