Visio Resizing Text

Visio has an annoying feature where the text size is always fixed, regardless of resizing. 

Most other tools will resize the text if you have the object as a group (e.g. Inkscape).

To convert all text to resize, here's a macro from https://visguy.com/vgforum/index.php?topic=1797.30

I've modified this macro to always use an integer size for the font, and added another macro to convert this back into a fixed size.

The macros are:

1. ChangeAllTextToAutoresize: Changes all the shapes in the drawing to automatically resize the text when the object is resized.

2. ChangeAllTextToFixed: Reverts the formula back to a fixed text size so that the objects can be resized without affecting the font size.

To run this macro, press ALT-F11 > Insert > Module > paste in the code > click on "ChangeAllTextToAutoresize" or "ChangeAllTextToFixed" > F5.

TODO:

1. Only modify the selected object, and not everything on the page.

Sub ChangeAllTextToAutoresize()

'As the name suggests, this Makro has to be started

Dim shp As Visio.Shape

Dim pg As Visio.Page

For Each pg In Application.ActiveDocument.Pages

  For Each shp In pg.Shapes

    Change_Formula shp

  Next

Next

End Sub

Sub Change_Formula(ByVal shp As Visio.Shape)

Dim douHeight As Double

Dim douCharSize As Double

Dim strFormula As String

Dim SubShape As Visio.Shape

Dim i As Integer

'Change the selected shape

douHeight = shp.Cells("Height").Result("MM")

For i = 0 To shp.Section(3).Count - 1

  douCharSize = shp.Section(3).Row(i).Cell(7).Result("pt.")

  strFormula = "int(Height/" & douHeight & " mm *" & douCharSize & " pt.)"

  shp.Section(3).Row(i).Cell(7).Formula = strFormula

Next i

'Change Sub Shapes by calling this function again

For Each SubShape In shp.Shapes

Change_Formula SubShape

Next

End Sub

Sub ChangeAllTextToFixed()

'As the name suggests, this Makro has to be started

Dim shp As Visio.Shape

Dim pg As Visio.Page

For Each pg In Application.ActiveDocument.Pages

  For Each shp In pg.Shapes

    Fix_Formula shp

  Next

Next

End Sub

Sub Fix_Formula(ByVal shp As Visio.Shape)

' Changes the text formula to just a static number

Dim douHeight As Double

Dim douCharSize As Double

Dim strFormula As String

Dim SubShape As Visio.Shape

Dim i As Integer

'Change the selected shape

douHeight = shp.Cells("Height").Result("MM")

For i = 0 To shp.Section(3).Count - 1

  douCharSize = shp.Section(3).Row(i).Cell(7).Result("pt.")

  strFormula = douCharSize

  shp.Section(3).Row(i).Cell(7).Formula = strFormula & "pt."

Next i

'Change Sub Shapes by calling this function again

For Each SubShape In shp.Shapes

  Change_Formula SubShape

Next

End Sub