Adding a Large Number of Shapes is Very Slow

[vdivito]

Adding a Large Number of Shapes is Very Slow in Word 2002

I have a fairly simple macro that adds 186 WordArt shapes to a Word document. When the macro starts it executes fairly quickly for the first few rows of shapes and then starts to get progressively slower as it goes. It seems if there are more than just a few shapes on the doc things get really slow. Execution takes minutes. Any suggestions are appreciated. My code is here:


Option Explicit

Sub Test()

Dim s As String
Dim a As Integer
Dim i As Integer
Dim vpos As Long
Dim hpos As Long
Dim oShape As Shape


Application.ScreenUpdating = False

vpos = 104

For a = 1 To 31

hpos = 53

s = a

'Place line number
Set oShape = ActiveDocument.Shapes.AddTextEffect _
(PresetTextEffect:=msoTextEffect6, _
Text:=s, _
FontName:="Comic Sans MS", _
FontSize:=10, _
FontBold:=False, _
FontItalic:=False, _
Left:=0#, _
Top:=0#)

With oShape
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.ScaleHeight 0.7, msoFalse, msoScaleFromBottomRight
.TextEffect.ToggleVerticalText
.Fill.ForeColor = vbRed
.Line.BackColor.RGB = RGB(0, 0, 0)
.Shadow.ForeColor.RGB = RGB(0, 0, 0)
.Line.Visible = msoFalse
.IncrementRotation 0
.WrapFormat.Type = wdWrapNone
.ZOrder msoBringToFront
.Left = hpos - .Width
.Top = vpos
End With
Set oShape = Nothing


'Place 5 three digit numbers
hpos = 85

For i = 1 To 5

s = "333"

Set oShape = ActiveDocument.Shapes.AddTextEffect _
(PresetTextEffect:=msoTextEffect6, _
Text:=s, _
FontName:="Comic Sans MS", _
FontSize:=12, _
FontBold:=True, _
FontItalic:=False, _
Left:=0#, _
Top:=0#)


With oShape

.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.ScaleWidth 1.4, msoFalse, msoScaleFromTopLeft
.ScaleHeight 0.6, msoFalse, msoScaleFromBottomRight
.TextEffect.ToggleVerticalText
.Fill.ForeColor = vbRed
.Line.BackColor.RGB = RGB(0, 0, 0)
.Shadow.ForeColor.RGB = RGB(0, 0, 0)
.Line.Visible = msoFalse
.IncrementRotation 0
.WrapFormat.Type = wdWrapNone
.ZOrder msoBringToFront
.Left = hpos
.Top = vpos

End With

Set oShape = Nothing

hpos = hpos + 61
Next i

vpos = vpos + 13.5
Next a

Application.ScreenUpdating = True


End Sub

 

[macropod]

Hi vdivito,

I don't see any slowing down (Word 2000) - in fact a slight increase in speed.

If you run the code as:

Sub Test()
Dim s As String
Dim a As Integer
Dim i As Integer
Dim vpos As Long
Dim hpos As Long
Dim oShape As Shape
Dim eTime As Long
eTime = Now
Application.ScreenUpdating = False
ActiveWindow.View.ShowPicturePlaceHolders = True
vpos = 104
For a = 1 To 31
  hpos = 53
  s = a
  'Place line number
  Set oShape = ActiveDocument.Shapes.AddTextEffect _
    (PresetTextEffect:=msoTextEffect6, _
    Text:=s, _
    FontName:="Comic Sans MS", _
    FontSize:=10, _
    FontBold:=False, _
    FontItalic:=False, _
    Left:=0#, _
    Top:=0#)
    With oShape
    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
    .ScaleHeight 0.7, msoFalse, msoScaleFromBottomRight
    .TextEffect.ToggleVerticalText
    .Fill.ForeColor = vbRed
    .Line.BackColor.RGB = RGB(0, 0, 0)
    .Shadow.ForeColor.RGB = RGB(0, 0, 0)
    .Line.Visible = msoFalse
    .IncrementRotation 0
    .WrapFormat.Type = wdWrapNone
    .ZOrder msoBringToFront
    .Left = hpos - .Width
    .Top = vpos
    End With
    Set oShape = Nothing
  'Place 5 three digit numbers
  hpos = 85
  For i = 1 To 5
    s = Format((Now - eTime) * 10, "0.000")
    eTime = Now
    Set oShape = ActiveDocument.Shapes.AddTextEffect _
      (PresetTextEffect:=msoTextEffect6, _
      Text:=s, _
      FontName:="Comic Sans MS", _
      FontSize:=12, _
      FontBold:=True, _
      FontItalic:=False, _
      Left:=0#, _
      Top:=0#)
    With oShape
      .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
      .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      .ScaleWidth 1.4, msoFalse, msoScaleFromTopLeft
      .ScaleHeight 0.6, msoFalse, msoScaleFromBottomRight
      .TextEffect.ToggleVerticalText
      .Fill.ForeColor = vbRed
      .Line.BackColor.RGB = RGB(0, 0, 0)
      .Shadow.ForeColor.RGB = RGB(0, 0, 0)
      .Line.Visible = msoFalse
      .IncrementRotation 0
      .WrapFormat.Type = wdWrapNone
      .ZOrder msoBringToFront
      .Left = hpos
      .Top = vpos
    End With
    Set oShape = Nothing
    hpos = hpos + 61
    Next i
vpos = vpos + 13.5
Next a
ActiveWindow.View.ShowPicturePlaceHolders = False
Application.ScreenUpdating = True
End Sub

You'll get the timings for each insertion.

Note the addition of the two lines relating to 'ShowPicturePlaceHolders'. This makes the code run slightly faster.


Cheers
[MS MVP - Word]

 

[vdivito]

Thanks for your response. I appreciate the pointers on speeding up the main block of code but my real problem is that the code gets slower as more shapes are added to the document. I inserted a timer into my code and you can see here the execution time of each main loop which places 6 shapes. The second set of times is the macro executed with 186 shapes already present on the document.

Loop 1 time: 0.578125 seconds
Loop 2 time: 0.65625 seconds
Loop 3 time: 1.046875 seconds
Loop 4 time: 1.375 seconds
Loop 5 time: 1.90625 seconds
Loop 6 time: 2.125 seconds
Loop 7 time: 2.390625 seconds
Loop 8 time: 2.75 seconds
Loop 9 time: 3.09375 seconds
Loop 10 time: 3.546875 seconds
Loop 11 time: 3.953125 seconds
Loop 12 time: 4.484375 seconds
Loop 13 time: 5.03125 seconds
Loop 14 time: 5.546875 seconds
Loop 15 time: 6.109375 seconds
Loop 16 time: 6.65625 seconds
Loop 17 time: 7.203125 seconds
Loop 18 time: 7.703125 seconds
Loop 19 time: 8.21875 seconds
Loop 20 time: 8.8125 seconds
Loop 21 time: 9.34375 seconds
Loop 22 time: 9.921875 seconds
Loop 23 time: 10.5625 seconds
Loop 24 time: 11.21875 seconds
Loop 25 time: 11.78125 seconds
Loop 26 time: 12.42188 seconds
Loop 27 time: 12.95313 seconds
Loop 28 time: 13.57813 seconds
Loop 29 time: 14.28125 seconds
Loop 30 time: 15.73438 seconds
Loop 31 time: 15.48438 seconds


With 186 shapes already present:

Loop 1 time: 16.42188 seconds
Loop 2 time: 18.5 seconds
Loop 3 time: 19.85938 seconds
Loop 4 time: 16.98438 seconds
Loop 5 time: 18.15625 seconds
Loop 6 time: 19.34375 seconds
Loop 7 time: 18.42188 seconds
Loop 8 time: 19.57813 seconds
Loop 9 time: 19.17188 seconds
Loop 10 time: 20.76563 seconds
Loop 11 time: 20.23438 seconds
Loop 12 time: 20.48438 seconds
Loop 13 time: 22.25 seconds
Loop 14 time: 23.67188 seconds
Loop 15 time: 23.75 seconds
Loop 16 time: 23.32813 seconds
Loop 17 time: 29.64063 seconds
Loop 18 time: 26.20313 seconds
Loop 19 time: 26.3125 seconds
Loop 20 time: 25.64063 seconds
Loop 21 time: 25.65625 seconds
Loop 22 time: 26.0625 seconds
Loop 23 time: 27.79688 seconds
Loop 24 time: 29.71875 seconds
Loop 25 time: 30.0625 seconds
Loop 26 time: 30.95313 seconds
Loop 27 time: 32.46875 seconds
Loop 28 time: 31.73438 seconds
Loop 29 time: 31.5625 seconds
Loop 30 time: 30.96875 seconds
Loop 31 time: 34.76563 seconds

 

[macropod]

For the benefit of everyone here, the same issue is being discussed at:

http://www.vbaexpress.com/forum/showthread.php?t=28243

vdivito:
I had hoped you'd get the message about correct cross-posting etiquette from the link to:

http://www.excelguru.ca/node/7

You should have told people here about that. It would also obviate the need to post the same material in both forums.


Cheers
[MS MVP - Word]