Displaying Document Fonts

There have been some posts recently about fonts may not displaying correctly in Visio, the Viewer, or in exports to PDF or XPS.  So, I thought it would be good to be have a bit of code that enables you to see all of the different fonts on a Visio page.  You can then use it to select a font, or to check how they are seen in different formats.

The following code will divide the active Visio page into three columns, creating a separate shape for each font name in order.  The font index and name are displayed in the particular font, but the ScreenTip of each shape displays the information, just in case you can’t read it in the shape!

Public Sub DisplayFonts()
Dim fnt As Visio.Font
Dim shp As Visio.Shape
Dim cols As Integer
Dim col As Integer
Dim maxRows As Integer
Dim row As Integer

Dim x1 As Double
Dim y1 As Double
Dim x2 As Double
Dim y2 As Double
Dim width As Double
Dim height As Double

cols = 3
col = 0
maxRows = CInt(1 + (Visio.ActiveDocument.Fonts.Count / cols))
width = ((Visio.ActivePage.PageSheet.Cells(“PageWidth”).ResultIU – _
Visio.ActivePage.PageSheet.Cells(“PageLeftMargin”).ResultIU – _
Visio.ActivePage.PageSheet.Cells(“PageRightMargin”).ResultIU) / cols)
height = ((Visio.ActivePage.PageSheet.Cells(“PageHeight”).ResultIU – _
Visio.ActivePage.PageSheet.Cells(“PageTopMargin”).ResultIU – _
Visio.ActivePage.PageSheet.Cells(“PageBottomMargin”).ResultIU) / maxRows)

For Each fnt In Visio.ActiveDocument.Fonts

If row Mod maxRows = 0 Then
col = col + 1
End If

row = row + 1
x1 = Visio.ActivePage.PageSheet.Cells(“PageLeftMargin”).ResultIU + (col – 1) * (width)
y1 = Visio.ActivePage.PageSheet.Cells(“PageHeight”).ResultIU – _
Visio.ActivePage.PageSheet.Cells(“PageTopMargin”).ResultIU – _
((row – ((col – 1) * maxRows) – 1) * height)
x2 = x1 + (Visio.ActivePage.PageSheet.Cells(“PageWidth”).ResultIU / cols)
y2 = y1 + height
Set shp = Visio.ActivePage.DrawRectangle(x1, y1, x2, y2)
shp.Text = fnt.id & vbTab & fnt.Name
shp.Cells(“Para.HorzAlign”).Formula = “=0”
shp.Cells(“Geometry1.NoFill”).Formula = “=1”
shp.Cells(“Geometry1.NoLine”).Formula = “=1”
shp.Cells(“Char.Size”).Formula = “=8 pt”
shp.Cells(“Char.Font”).Formula = “=” & CStr(fnt.id)
shp.Cells(“Comment”).Formula = “=””” & fnt.id & vbCrLf & fnt.Name & “”””
Next
End Sub