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

DrHacker

New Member
Joined
Jun 4, 2018
Messages
22
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)

VBA Code:
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!
 

Attachments

Some videos you may like

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,044
Office Version
2007
Platform
Windows
How about:

VBA Code:
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
11,044
Office Version
2007
Platform
Windows
Im glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,095,167
Messages
5,442,785
Members
405,196
Latest member
rmuir12

This Week's Hot Topics

  • Copy entire row if CountA <>0 to another sheet
    [B]I want to copy entire row if CountA <>0 for column J7:AM7 (headers on J6:AM6) and so on till the last used cell is column D and paste the...
  • Select last used Row in Table
    I have created a Table in a Worksheet which is locked to prevent user errors and protect formula. Some of the cells require freetext entries which...
  • excel workbook: do not allow certain file name
    Hello all, Don't think this has ever been asked before, but how do I restrict file save [Before_Save Event] if the name of the file being saved...
  • fixing problem autofilter
    hello i need help about my code when i search by code in textbox it doesn't show anything this is my data [ATTACH type="full"...
  • “Weight”
    Hi, i’ve got a long sheet filled with weights such as kg,g,L & ml. i can build a formula to convert kg into g and liter into ml. How ever, my...
  • How to capitalize everything before a certain character?
    In column A, I have some text: Hello good day.mp3 Hello good day.flac etc. I'd like to capitalize everything before the period. I don't need the...
Top