Looking for Speed Enhancement for Large For ... Loop

[gmaxey]

Can any of you take a look at the attached. I know that Word VBA has been broken for sometime when it comes to processes large For ... Next loops. If you try to create a 1/16" grid, the process begins to slow down after the verticals are drawn, it gets slower, then slower yet then painfully slower as it goes on.


Any suggestions for improvement? Thanks.

[macropod]

A couple of pointers:
1. Your code to clear an existing grid could be reduced to:

If oFrm.chkClear Then ActiveDocument.Range.Delete

2. Instead of repeatedly creating and formatting oLine for each iteration of the loop, create three side-by-side textboxes, each one 1/3 of the page width and insert a table into each textbox with 1/3 of the columns (a Word table can span up to 63 columns and the most you'll need is 134) and however many rows you need, spacing the rows and columns as required. Strictly speaking, you only need two tables for 1/8" and three for 1/16" - all the rest could be done with one table. Even a 1/12" (6pt) grid would only require two tables.

An alternative approach would be to create a 1/4-page size textbox and insert 1/4 of the grid into that, then replicate three copies of the textbox, positioned appropriately on the page.

[gmaxey]

Paul,


Thanks for the comments!

[macropod]

You're welcome. Table creation is lightning fast compared to what your code's presently doing.

[gmaxey]

Paul,


Slow lighting but yes, for wide page small grid scenarios table creation is considerably faster. This could use a progress bar but shows the modified code:

Option Explicit
Dim intLW As Integer
Dim lngRows As Long
Dim lngColor As Long
Dim sngGSPoints As Single
Dim oTB As Shape
Sub DefineGT()
  DevelopGridTable 4.5, 0.25, 255 'Create 1/16" grids, line width 0.25", color red
End Sub
Sub DevelopGridTable(GSPpassed As Single, LWPassed As Single, BCPassed As Long)
Dim oTbl As Table
Dim oRng As Range
Dim oTB_2 As Shape, oTB_3 As Shape
Dim lngCols As Long, lngColSegs As Long, lngTSegs As Long
Dim lngGH As Long, lngGW As Long
Dim sngLWOffset As Single
Dim strAction As String
Dim bCopyTable As Boolean
  Application.ScreenUpdating = False
 'Clear range.
  Set oRng = ActiveDocument.Range
  oRng.Delete
  oRng.Collapse wdCollapseStart
  Application.ScreenUpdating = True
  Application.ScreenRefresh
  DoEvents
  Application.ScreenUpdating = False
  sngGSPoints = GSPpassed
  sngLWOffset = LWPassed
  lngColor = BCPassed
  If lngColor < 0 Then lngColor = wdColorAutomatic
  Select Case sngLWOffset
    Case Is = 0.25: intLW = 2
    Case Is = 0.5: intLW = 4
    Case Is = 0.75: intLW = 6
    Case Is = 1: intLW = 8
    Case Is = 1.5: intLW = 12
    Case Is = 2.25: intLW = 18
    Case Is = 3: intLW = 24
    Case Is = 4.5: intLW = 36
    Case Is = 6: intLW = 48
  End Select
  'Set margins to accommodate grid size and calculate number of grid lines required.
  With ActiveDocument.PageSetup
    .Orientation = wdOrientPortrait
    .LeftMargin = sngGSPoints
    .TopMargin = sngGSPoints
    .BottomMargin = sngGSPoints
    .RightMargin = sngGSPoints
    .HeaderDistance = .TopMargin - 4
    .FooterDistance = .BottomMargin - 4
    lngGH = .PageHeight - (.TopMargin + .BottomMargin)
    lngGW = .PageWidth - (.LeftMargin + .RightMargin)
    lngRows = Int(lngGH / sngGSPoints)
    lngCols = Int(lngGW / sngGSPoints)
    lngGW = lngCols * sngGSPoints
  End With
  'Calculate required tables.
  Select Case lngCols
    Case Is < 64
      lngTSegs = 1
    Case 64 To 127
      lngTSegs = 2
    Case 128 To 191
      lngTSegs = 3
  End Select
  If lngCols < 63 Then
    'One table needed. Create textbox container for table.
    Set oTB = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, lngGW, lngGH + 5, oRng)
    lngColSegs = lngCols
    strAction = "Grid Table"
  Else
    'Two or more tables needed. Create textbox container for first table.
    Set oTB = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, (sngGSPoints * 63), lngGH + 5, oRng)
    lngColSegs = 63
    strAction = "Grid Table Segment"
  End If
  'Configure textbox container.
  With oTB
    .Left = 0
    .Top = 0
    .TextFrame.MarginLeft = 1
    .TextFrame.MarginRight = 1
    .TextFrame.MarginTop = 0
    .TextFrame.MarginBottom = 0
    .WrapFormat.Type = wdWrapBehind
    .Line.Visible = msoFalse
  End With
  'Create table.
  Set oRng = oTB.TextFrame.TextRange
  oRng.Collapse wdCollapseStart
  oRng.Font.Size = 4
  InsertTableInRange oRng, lngColSegs, False, strAction
  Set oRng = ActiveDocument.Range
  oRng.Collapse wdCollapseEnd
  Application.ScreenUpdating = True
  Application.ScreenRefresh
  DoEvents
  Application.ScreenUpdating = False
  If lngTSegs > 1 Then
    bCopyTable = False
    'Second or final second table.
    If lngCols - 63 < 63 Then
      'One additional grid table segment needed. Create textbox container for grid table segment.
      lngColSegs = lngCols - 63
      Set oTB_2 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, (sngGSPoints * lngColSegs), lngGH + 5, oRng)
      strAction = "final Grid Table Segment"
      bCopyTable = True
    Else
      'Second and final grid table segments needed. Create textbox container for second grid table segment.
      Set oTB_2 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, (sngGSPoints * 63), lngGH + 5, oRng)
      strAction = "Grid Table Segment"
      bCopyTable = True
    End If
    'Configure textbox container for grid table segment.
    With oTB_2
      If oTB.Left < 0 Then oTB.Left = 0
      .Left = sngGSPoints * 63
      .Top = 0
      .TextFrame.MarginLeft = 1
      .TextFrame.MarginRight = 1
      .TextFrame.MarginTop = 0
      .TextFrame.MarginBottom = 0
      .WrapFormat.Type = wdWrapBehind
      .Line.Visible = msoFalse
    End With
    Set oRng = oTB_2.TextFrame.TextRange
    oRng.Collapse wdCollapseStart
    oRng.Font.Size = 1
    If bCopyTable Then
      oTB.TextFrame.TextRange.FormattedText.Copy
      oRng.FormattedText.Paste
      oRng.Tables(1).Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    Else
      InsertTableInRange oRng, lngColSegs, True, strAction
    End If
    oTB_2.Left = oTB.Width - 2
    If lngTSegs > 2 Then
      Application.ScreenUpdating = True
      Application.ScreenRefresh
      DoEvents
      Application.ScreenUpdating = False
      'Third grid table segment required. Create textbox container.
      lngColSegs = lngCols - (63 + 63)
      Set oTB_3 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, (sngGSPoints * lngColSegs), lngGH + 5, oRng)
      '*** GKM - Weirdness here.  Sometimes error occurs.  Even though shape is there, the code thinks it isn't.
      On Error Resume Next
        Debug.Print oTB_3.Height
      If Err.Number <> 0 Then
        DoEvents
        Err.Clear
        Set oTB_3 = ActiveDocument.Shapes(3)
      End If
      On Error GoTo 0
      'Configure textbox container for third and final table.
      With oTB_3
        .Left = sngGSPoints * (63 * 2)
        .Top = 0
        .TextFrame.MarginLeft = 1
        .TextFrame.MarginRight = 1
        .TextFrame.MarginTop = 0
        .TextFrame.MarginBottom = 0
        .WrapFormat.Type = wdWrapBehind
        .Line.Visible = msoFalse
      End With
      Set oRng = oTB_3.TextFrame.TextRange
      oRng.Collapse wdCollapseStart
      oRng.Font.Size = 1
      InsertTableInRange oRng, lngColSegs, True, "final Grid Table Segment"
      DoEvents
      oTB_3.Left = oTB.Width + oTB_2.Width - 4
    End If
  End If
  Set oRng = ActiveDocument.Range
  oRng.Font.Size = 12
  oRng.Collapse wdCollapseStart
  oRng.Select
  Application.ScreenUpdating = True
  Application.ScreenRefresh
lbl_Exit:
  Exit Sub
End Sub
Function InsertTableInRange(oRng As Range, lngCols As Long, bHideLeftBorder As Boolean, strAction As String)
Dim oTbl As Table
Dim lngIndex As Long
  Set oTbl = oRng.Tables.Add(oRng, lngRows, lngCols, wdAutoFitWindow)
  With oTbl
    .Range.Font.Size = 4
    .Rows.HeightRule = wdRowHeightExactly
    .Rows.Height = sngGSPoints
    For lngIndex = 1 To 6
      .Borders(-lngIndex).LineStyle = wdLineStyleSingle
      If bHideLeftBorder Then .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
      On Error Resume Next
        .Borders(-lngIndex).LineWidth = intLW
        .Borders(-lngIndex).Color = lngColor
      On Error GoTo 0
      DoEvents
    Next lngIndex
    .TopPadding = InchesToPoints(0)
    .BottomPadding = InchesToPoints(0)
    .LeftPadding = InchesToPoints(0)
    .RightPadding = InchesToPoints(0)
    .AutoFitBehavior (wdAutoFitFixed)
    If bHideLeftBorder Then oTbl.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
    If .Rows.Count * (sngGSPoints) > oTB.Height Then .Rows.Last.Delete
  End With
lbl_Exit:
  Exit Function
End Function