Can anyone help me please
The bit of code below outputs 30 text boxes onto a page and takes about 25
seconds to do.
This is a trial sample of something I am trying to develop.
My 2 Questions are
1) Is there a limit to the number of text boxes you can output to a
document, and
2) If not, how can I speed this up. The application I am working on
potentially has thousands of text boxes to output over 10s of pages.
Many thanks
Phil
Option Explicit
Function DrawTextBoxs(NoBoxes As Integer)
Dim i As Long
Dim TopCorner As Long
Dim LeftCorner As Long
For i = 1 To NoBoxes
If LeftCorner = 0 Then
LeftCorner = 20
Else
LeftCorner = LeftCorner + 150
End If
If TopCorner = 0 Then
TopCorner = 10
End If
If LeftCorner > 500 Then
LeftCorner = 20
TopCorner = TopCorner + 100
End If
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal,
LeftCorner, TopCorner, 100, 80).Select
Selection.ShapeRange.Select
With Selection.ShapeRange
.TextFrame.MarginLeft = 0#
.TextFrame.MarginRight = 0#
.TextFrame.MarginTop = 0#
.TextFrame.MarginBottom = 0#
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor = i * 3000
.Fill.Transparency = 0#
.Line.Transparency = 0#
.Line.Visible = msoTrue
If i / 2 = i \ 2 Then
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Weight = 5
Else
.Line.DashStyle = msoLineSquareDot
.Line.Style = msoLineSingle
.Line.Weight = 2
End If
.Line.Style = msoLineSingle
.Line.ForeColor = 1500000 - (i * 2000)
End With
With Selection.Font
If i / 2 = i \ 2 Then
.NameAscii = "Arial"
Else
.NameAscii = "Comic Sans"
End If
.Size = 10 + i \ 2
.Bold = True
.Italic = False
.Underline = True
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = 2000 + (i * 3500)
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = 100
.Position = 0
.Kerning = 0
.Animation = wdAnimationNone
End With
' Center
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeText Text:="This is Text Box " & i
Selection.Collapse
Next i
End Function
Sub Test()
'
' Test Macro
' Macro created 07/12/2004
'
Call DrawTextBoxs(30)
End Sub