Hello,
here is the promised version that changes the formula in the Tabs Section, too.
But it is still not perfect. The shape can now shrink more before the text gets disrupted, but at a certain point it will get disrupted, no matter what.
Maybe the formula has to be more complex, taking into account the different fonts itself, the number of characters before and after a tab and and and...
The only benefit is that the shapes now look better than before, when they get bigger. Thats because they always look the same now, thanks to the although growing Tab.
Dim strFormula As String
Dim SubShape As Visio.Shape
Dim i, j As Integer
On Error Resume Next
'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 = "Height/" & douHeight & " mm *" & douCharSize & " pt."
shp.Section(3).Row(i).Cell(7).Formula = strFormula
Next i
For j = 0 To shp.Section(5).Count - 1
For i = 1 To shp.Section(5).Row(j).Count Step 3
douTab = shp.Section(5).Row(j).Cell(i).Result("MM")
strFormula = "Height/" & douHeight & " mm *" & douTab & " mm"
shp.Section(5).Row(j).Cell(i).Formula = strFormula
Next i
Next j
'Change Sub Shapes by calling this function again
For Each SubShape In shp.Shapes
Change_Formula SubShape
Next
End Sub
Sub Start()
'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
Thats the best I could come up with in my little spare time. Maybe it's enough.
