Word 2003 Styles VBA optimization

[Charles Belov]

I have some VBA macros to enforce certain styles. They are working, but
running slowly, such that a 3-year-old computer with 2 meg of memory is
taking 11 seconds to do its magic on 5 paragraphs of text. Searching on VBA
optimization, I haven't seen anything on how to optimize code when updating
styles. I also don't see any document methods or properties which tell Word
not to update the text to agree with the styles until I am done setting
everything.



My code is as follows. The macros SetDocStylesToSFMTAStyles and
SetToLeftJustifyForEditing are the ones executed by the person editing the
document.



Option Explicit
Global strNameLocalNormal As String
Global strNameLocalDefault As String
Global strNameLocalHeader As String



Sub SetDocStylesToSFMTAStyles()
Call Start_Optimization
Call Initialize_Styles(ActiveDocument)
Call SubSetStyles(ActiveDocument, _
wdAlignParagraphJustify)
Call End_Optimization
End Sub


Sub SetToLeftJustifyForEditing()
Call Start_Optimization
Call Initialize_Styles(ActiveDocument)
Call SubSetStyles(ActiveDocument, _
wdAlignParagraphLeft)
Call End_Optimization
End Sub



Sub Start_Optimization()
Application.ScreenUpdating = False
End Sub



Sub Initialize_Styles(myDoc)
strNameLocalNormal = myDoc.Styles(wdStyleNormal).NameLocal
strNameLocalHeader = myDoc.Styles(wdStyleHeader).NameLocal
End Sub



Sub SubSetStyles(myDoc, myJust)



Dim myStyle As Style
For Each myStyle In myDoc.Styles
Select Case myStyle.NameLocal
Case "Normal"
Call SubSetOneStyle(myDoc, "Heading 1", _
12, False, False, myJust, vbNullString)
Case "Heading 1"
Call SubSetOneStyle(myDoc, "Heading 1", _
17, True, False, wdAlignParagraphLeft, "Normal")
Case "Heading 2"
Call SubSetOneStyle(myDoc, "Heading 2", _
12, True, True, wdAlignParagraphLeft, "Normal")
Case "Heading 3"
Call SubSetOneStyle(myDoc, "Heading 3", _
12, True, True, wdAlignParagraphLeft, "Normal")
Case "Caption"
Call SubSetOneStyle(myDoc, "Caption", _
10, False, False, myJust, "Normal")
Case "Footnote"
Call SubSetOneStyle(myDoc, "Footnote", _
10, False, False, myJust, "Normal")
Case "Header"
Call SubSetOneStyle(myDoc, "Header", _
10, False, False, wdAlignParagraphLeft, vbNullString)
Case "Footer"
Call SubSetOneStyle(myDoc, "Footer", _
10, False, False, wdAlignParagraphLeft, vbNullString)
Case Else
Call SubSetOneStyle(myDoc, myStyle, 12, _
False, False, myJust, "Normal")
End Select
Next myStyle



End Sub



Sub SubSetOneStyle(myDoc, myStyle, mySize, _
myBold, myItalic, myJust, myBase)



With myDoc.Styles(myStyle).Font
.NameAscii = "Arial"
.NameOther = "Arial"
.Name = "Arial"
.Size = mySize
.Bold = myBold
.Italic = myItalic
.Underline = wdUnderlineNone
.UnderlineColor = wdColorBlack
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorBlack
.Engrave = False
.Superscript = False
.Subscript = False
.Scaling = 100
.Kerning = 0
.Animation = wdAnimationNone
.EmphasisMark = wdEmphasisMarkNone
End With
With myDoc.Styles(myStyle)
On Error Resume Next
.AutomaticallyUpdate = False
.NextParagraphStyle = "Normal"
.ParagraphFormat.Alignment = myJust
.BaseStyle = myBase
On Error GoTo 0
End With
Exit Sub

End Sub

Sub End_Optimization()
Application.ScreenUpdating = True
End Sub