Tag: office 2007

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…