Font chooser macro

When we need a fine font for specific text we need to write down the text and test the text by changing its font. Its time consuming. So, I make a small macro in microsoft word by VBA macro that prompt you to input the text and draw that text by assigning all available font from your system into different line. Moreover it input the corresponding font name at the starting point of each line.

Here is the macro code FYI:

Sub fontChooserByRazon()
' ' fontChooserByRazon Macro V:1.02 (razonklnbd [at] yahoo [dot] com) ' ' Dim txtStr As String, fntIdx As Long, fntNameLen As Long txtStr = InputBox("Input a text to show through various font of your computer", "Text for font chooser", "The quick brown fox jumps over the lazy dog.") fntIdx = 1 For fntIdx = 1 To Application.FontNames.Count
fntNameLen = Len(Application.FontNames(fntIdx)) Selection.TypeText Text:=Application.FontNames(fntIdx) & ": " & txtStr Selection.StartOf Unit:=wdParagraph Selection.StartIsActive = False Selection.MoveRight Unit:=wdCharacter, Count:=fntNameLen + 2 Selection.StartIsActive = True Selection.MoveEnd Unit:=wdParagraph Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend With Selection.Font
.Name = Application.FontNames(fntIdx) .Size = 12
End With Selection.MoveRight Selection.TypeText Chr(13)
Next fntIdx
End Sub

 

Sub selectedFontChooserByRazon()
' ' selectedFontChooserByRazon Macro V:1.05 (razonklnbd [at] yahoo [dot] com) ' ' Dim txtStr As String, fntIdx As Long, fntNameLen As Long, getInputFromUser As Boolean getInputFromUser = True txtStr = Trim(CStr(Selection.Text)) If Len(txtStr) > 2 Then
getInputFromUser = False Selection.StartOf Unit:=wdParagraph Selection.MoveEnd Unit:=wdParagraph Selection.MoveRight Selection.TypeText Chr(13) Selection.MoveLeft
End If If getInputFromUser Then
txtStr = InputBox("Input a text to show through various font of your computer", "Text for font chooser", "The quick brown fox jumps over the lazy dog.")
End If If Len(txtStr) > 2 Then
Selection.TypeText Chr(13) fntIdx = 1 For fntIdx = 1 To Application.FontNames.Count
With Selection.Font
.Name = "Verdana" .Size = 12
End With fntNameLen = Len(Application.FontNames(fntIdx)) Selection.TypeText Text:=Application.FontNames(fntIdx) & ": " & txtStr Selection.StartOf Unit:=wdParagraph Selection.StartIsActive = False Selection.MoveRight Unit:=wdCharacter, Count:=fntNameLen + 2 Selection.StartIsActive = True Selection.MoveEnd Unit:=wdParagraph 'Selection.EndKey Unit:=wdLine, Extend:=wdExtend Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend With Selection.Font
.Name = Application.FontNames(fntIdx) .Size = 12
End With Selection.MoveRight Selection.TypeText Chr(13)
Next fntIdx
End If
End Sub

Here is the screenshot:

This is my first VBA macro… If you have more suitable version please share with me…

Advertisements