PowerPoint Macro: List Fonts at ComboBox - Optimization required (Execution too Slow - More than a minute and half)

[DrHacker]

Experts, i created a form to load in ComboBox ALL Installed Fonts on system & sort them. Macro was created in PowerPoint; it takes More than a minute and a Half to finish the execution and show the form.

It could be accelerated to reduce it (30 secs for example)?

I guess the way that i programmed it is affecting the performance. Someone can support me with suggestions to improve it?

(Added Word Libraries as part of the code to use it)

Dim fontList As CommandBarControl
Dim Tempbar As CommandBar
Dim i As Long
Dim TempFonts As Variant
    Dim wd As Object, fontID As Variant

    Set wd = CreateObject("Word.Application")

        For Each fontID In wd.FontNames

For i = 0 To cboFontOther.ListCount - 1

cboFontOther.ListIndex = i

If fontID < cboFontOther.Value Then

cboFontOther.AddItem (fontID), i

GoTo Skiphere

End If

Next i

cboFontOther.AddItem (fontID)

Skiphere:

Next

wd.Quit

Set wd = Nothing

    Me.cboFontOther.Text = "Arial"

    On Error Resume Next

    With FontSelectionForm

         .StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
         .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)

    End With

End Sub

Form attached as picture.

Name References on the Form

lblFontcboOverLabel = Sample Text (Label)

cboFontOther = ComboBox to select fonts

Frame1 = Frame where font name

Thanks!

 

[DanteAmor]

How about:

Private Sub UserForm_Activate()
  Dim wd As Object, fontID As Variant, arrList As Object
  
  Set arrList = CreateObject("System.Collections.ArrayList")
  Set wd = CreateObject("Word.Application")
  
  For Each fontID In wd.FontNames
    arrList.Add fontID
  Next
  arrList.Sort
  cboFontOther.List = arrList.toArray
  
  wd.Quit
  Set wd = Nothing
  Me.cboFontOther.Text = "Arial"
  On Error Resume Next
  With FontSelectionForm
    .StartUpPosition = 0
    .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
    .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
  End With
End Sub

 

[DrHacker]

Just WOW! it Works in les tan 3/5 seconds.

Awesome help! Thanks a lot.

 

[DanteAmor]

Im glad to help you. Thanks for the feedback.