Changing font type in the entire document

[Pista]

I have the following function:

Private Function ReAut(root As Object)
Dim shpsObj As Visio.Shapes
Dim shpObj As Visio.Shape
Dim trebuchetMS As Double
Dim courierNew As Double
Set shpsObj = root.Shapes

For Each shpObj In shpsObj
trebuchetMS = ActiveDocument.Fonts("Trebuchet MS").Index
courierNew = ActiveDocument.Fonts("Courier New").Index
If shpObj.Type = visTypeGroup Then
For j = 0 To 20 Step 1 'zatial neviem zistit pocet stlpcov v
sekcii charakter, tak tam davam napevno 20
If shpObj.CellsSRCExists(visSectionCharacter, j,
visCharacterFont, 1) Then
If shpObj.CellsSRC(visSectionCharacter, j,
visCharacterFont).Result("") <> courierNew Then
shpObj.CellsSRC(visSectionCharacter, j,
visCharacterFont).FormulaForceU = trebuchetMS
End If
Else
Exit For
End If
Next j
ReAut = ReAut(shpObj)
Else
For k = 0 To 20 Step 1 'zatial neviem zistit pocet stlpcov v
sekcii charakter, tak tam davam napevno 20
If shpObj.CellsSRCExists(visSectionCharacter, k,
visCharacterFont, 1) Then
If shpObj.CellsSRC(visSectionCharacter, k,
visCharacterFont).Result("") <> courierNew Then
shpObj.CellsSRC(visSectionCharacter, k,
visCharacterFont).FormulaForceU = trebuchetMS
End If
Else
Exit For
End If
Next k
End If
Next
ReAut = 0
End Function

I have used it in a UserForm (I have created an Open Directory dialog there
to select the source directory for all my Visio documents).

So my macro would change the font to Trebuchet MS in all shapes and in all
files in my selected directory.

I have 6 files, but I get for example 4 files "trebuchetized" well, but 2
files wrong. I have no idea, what's wrong, but I've found out an interesting
thing - if I change trebuchetMS = ActiveDocument.Fonts("Trebuchet MS").Index
to trebuchetMS = 176 (I took it from the ShapeSheet of text with font
trebuchet-MS), it works for the other 2 files, but corrupts first 4 files

Thank for your help!

Pista

 

[JuneTheSecond]

My proposal is to emulate real operation on Visio drawing.
We usualy select all shape and chenge font on the tool bar.
Test code might be as below.
This code is limeted to a page, but I hope you could extend it to a document.
Microsoft object library should be included in reference.

Option Explicit

Sub test()
ActiveWindow.SelectAll
ChangeAllFont "Arial"
End Sub
Public Sub ChangeAllFont(Font As String)
Dim cbars As Office.CommandBars
Dim cbar As Office.CommandBar
Dim cbButton As Office.CommandBarButton
Dim cbCombo As Office.CommandBarComboBox
Dim cbc As Office.CommandBarControl

On Error GoTo ERRHAND

Set cbars = Application.CommandBars
For Each cbar In cbars
If cbar.Name = "Formatting" Then
For Each cbc In cbar.Controls
If cbc.ID = 1728 Then 'Font selection ComboBox
Set cbCombo = cbc
MsgBox "Font is chaning to " & Font
cbCombo.Text = Font
End If
Next
End If
For Each cbc In cbar.Controls
Next
Next
Exit Sub
ERRHAND:
MsgBox Err.Description
End Sub

 

[Pista]

Thank you very much! But my problem is not solved...

We used to guard everything we could (I don't know why but my boss wanted
it), so there exists a situation where I have the Font Type cell guarded. We
already have hundreds of visio documents finished, each 20 pages, they all
may have these cells guarded (almost all shapes taken from stencil) - so I
am not able to unguard all the stuff

Your code doesn't change a guarded cell. But thank you anyway - I will
definitely use your code somewhere.

Pista Holiga

 

[JuneTheSecond]

My next idea is to use Shapes.ItemFromID property to find all shapes.
Option Explicit

Sub test()
On Error GoTo ERREND
Dim shp As Visio.Shape
Dim I As Long, N As Long
N = 999
For I = 1 To N
Set shp = ActivePage.Shapes.ItemFromID(I)
shp.CellsSRC(visSectionCharacter, visRowCharacter, _
visCharacterFont).ResultForce("") = 3
Next
Exit Sub
ERREND:
MsgBox Err.Description & " " & I - 1 & " is Less than " & N
End Sub

 

[JuneTheSecond]

And this is faster than the other.

 

[Pista]

Good idea... I used it..

But got Run-time error '-2032465756 (86db08a4)':
Invalid sheet identifier.

 

[JuneTheSecond]

So, the error trap is important.
This macro always falls into error, if it runs normally as sceduled.
Because the Number of shapes has to be smaller than the number of loops