none
Slow performance word macro in Office 2019 RRS feed

  • Question

  • We have developed a word macro in 2007, It works fine in 2010. 

    If we use Macro AflijnenCurrentDoc in Word 2010 it takes 1 second to execute.

    If we use Macro AflijnenCurrentDoc in Word 2019 it takes 9 second to execute.

    Option Explicit

    Dim sols() As Long
    Dim eols() As Long
    Dim aantalregels As Long
    Dim viewtype As Long
    Dim bHiddenText As Boolean

    '//*    Naam        : CurrentPage(p As Long)
    '       Functie     :
    '//*    Versie      : Original
    Private Sub CurrentPage(p As Long)
        
        Dim x As Long
        Dim Maxregels, TryAgain As Long
        
        Maxregels = 200
        
    Again:
        ReDim sols(Maxregels), eols(Maxregels)
        
        aantalregels = 0
        With Selection
            .SetRange 0, 0
            'eerste regel:
            x = .Information(wdActiveEndPageNumber)
     
            If x = p Then
                sols(1) = .Start: aantalregels = 1
                .EndKey Unit:=wdLine, Extend:=wdMove: eols(1) = .End
            End If
            
            'rest van de regels:
            Do
                If .MoveDown(Unit:=wdLine, count:=1) = 0 Then
                    TryAgain = TryAgain + 1: If TryAgain = 5 Then Exit Do
                Else
                    TryAgain = 0: x = .Information(wdActiveEndPageNumber)
                    If x = p Then
                        aantalregels = aantalregels + 1
                        If aantalregels > Maxregels Then Exit Do
                        If .Information(wdWithInTable) = False Then
                            .HomeKey Unit:=wdLine, Extend:=wdMove: sols(aantalregels) = .Start
                            .EndKey Unit:=wdLine, Extend:=wdMove: eols(aantalregels) = .End
                        End If
                    End If
                End If
            Loop
        End With
        If aantalregels > Maxregels Then Maxregels = Maxregels + 500: GoTo Again:

    End Sub

    '//*    Naam        : wholepage()
    '       Functie     :
    '//*    Versie      : Original
    Private Sub wholepage()
        
        Dim p As Long
        Dim x
        Dim Maxregels
        Dim TryAgain As Long
        Maxregels = ActiveDocument.BuiltInDocumentProperties(23) + 250
        
    Again:
        ReDim sols(Maxregels), eols(Maxregels)
        aantalregels = 0
        With Selection
            .SetRange 0, 0
            'eerste regel:
            sols(1) = .Start: aantalregels = 1
            .EndKey Unit:=wdLine, Extend:=wdMove: eols(1) = .End
        
            'rest van de regels:
            Do
                If .MoveDown(Unit:=wdLine, count:=1) = 0 Then
                    TryAgain = TryAgain + 1: If TryAgain = 5 Then Exit Do
                Else
                    TryAgain = 0:
                    aantalregels = aantalregels + 1
                    If aantalregels > Maxregels Then Exit Do
                    If .Information(wdWithInTable) = False Then
                        'If Left$(.Style, 5) = "slot_" Then .ParagraphFormat.Reset
                        .HomeKey Unit:=wdLine, Extend:=wdMove: sols(aantalregels) = .Start
                        .EndKey Unit:=wdLine, Extend:=wdMove: eols(aantalregels) = .End
                    End If
                End If
            Loop
        End With
        If aantalregels > Maxregels Then Maxregels = 2 * Maxregels: GoTo Again
        
    End Sub 'wholepage()

    '//*    Naam        : init()
    '       Functie     :
    '//*    Versie      : Original
    Private Sub init()

        Dim sty As Style
        Dim opprof As String
        Dim findrange As Range
        Dim strSettingTestAflijnenOffice2010 As String
            
        Application.ScreenUpdating = False

        strSettingTestAflijnenOffice2010 = FastLookUp("systeem", "IDVALUE", "ID = 'TestOffice2010Aflijnen'")
        If (strSettingTestAflijnenOffice2010 <> "-1") Then
            viewtype = ActiveWindow.View.Type: ActiveWindow.View.Type = wdNormalView
        End If
        With ActiveWindow.View
            bHiddenText = .ShowHiddenText
            .ShowHiddenText = True
        End With
        
        Selection.HomeKey Unit:=wdStory, Extend:=wdMove
        With ActiveDocument.StoryRanges(wdMainTextStory).Find
            .ClearFormatting: .Replacement.ClearFormatting
            .Execute findtext:="^w^p", ReplaceWith:="^p", Replace:=wdReplaceAll, Format:=0
            .Execute findtext:="^w^l", ReplaceWith:="^l", Replace:=wdReplaceAll, Format:=True
        End With
        ActiveDocument.UpdateStyles
        With ActiveDocument
            For Each sty In .Styles
                opprof$ = sty.NameLocal
                If Left$(opprof, 5) = "slot_" Then
                    Set findrange = .Content
                    With findrange.Find
                        .ClearFormatting
                        .Style = opprof
                        .Execute findtext:="", Wrap:=wdFindStop
                        Do While .Found
                            findrange.ParagraphFormat.Reset
                            .Execute findtext:="", Wrap:=wdFindStop
                        Loop
                    End With
                End If
            Next
        End With
        Set findrange = Nothing
        Selection.HomeKey Unit:=wdStory, Extend:=wdMove
        
    End Sub 'init()

    '//*    Naam        : voeruit()
    '       Functie     :
    '//*    Versie      : Original
    Private Sub voeruit()

        Dim soffset As Long
        Dim eoffset As Long
        Dim MyRange As Range
        Dim srange As Range
        Dim afsluitingrange As Range
       
        Dim x, I, inserts As Long, nm$, ft As Font, aanhalen, tabjes As Integer
        Dim naam1$, naam2$, metab$(4), uittab$(4), afbreek$(4), t$
        Dim tpos, yv, lm, rm, breed, lins, rins, ruimte As Single, posi, lead, aligned As Long
        Dim aflijnsetting As Long
        Dim strSettingTestAflijnenOffice2010 As String
        
        
        aflijnsetting = Val(GetMSSProfile("aflijnsetting"))
        
        metab$(0) = ""
        metab$(1) = vbTab
        metab$(2) = vbTab & vbTab
        metab$(3) = vbTab & vbTab & vbTab
        metab$(4) = vbTab & vbTab & vbTab & vbTab
        uittab$(0) = ""
        uittab$(1) = vbTab & Chr(11)
        uittab$(2) = vbTab & vbTab & Chr(11)
        uittab$(3) = vbTab & vbTab & vbTab & Chr(11)
        uittab$(4) = vbTab & vbTab & vbTab & vbTab & Chr(11)
        afbreek$(0) = ""
        afbreek$(1) = "-" & uittab$(1)
        afbreek$(2) = "-" & uittab$(2)
        afbreek$(3) = "-" & uittab$(3)
        afbreek$(4) = "-" & uittab$(4)
        
        naam1$ = "aangehaald": naam2$ = "aangehaald_vervolg"
        
        
        With ActiveDocument
            On Error Resume Next
            Set ft = .Styles("aflijntab").Font: x = ft.size
            If x = 0 Then Set ft = .Styles(wdStyleNormal).Font
            
            On Error GoTo 0
            For I = 1 To aantalregels
                tabjes = 1
                soffset = sols(I) + inserts
                Set srange = .Range(soffset, soffset)
                If srange.Style = naam1$ Or srange.Style = naam2$ Then
                    aanhalen = True
                Else
                    aanhalen = False
                End If
                nm$ = LCase(Left$(srange.Style, 3))
            
                If nm$ = "kop" Then
                    tpos = srange.Paragraphs(1).TabStops(1).Position
                    lead = srange.Paragraphs(1).TabStops(1).Leader
                    aligned = srange.Paragraphs(1).TabStops(1).Alignment
                    If aligned = wdAlignTabCenter And lead <> wdTabLeaderSpaces Then
                        srange.Text = metab$(1): inserts = inserts + 1 ' centrerend uitvullen
                        srange.Font = ft
                    End If
                ElseIf nm$ = "nie" Or srange.Font.hidden = True Then
                    GoTo nexfor
                ElseIf nm$ = "slo" And ((aflijnsetting And 1) = 1) Then
                    GoTo nexfor
                ElseIf LCase$(srange.Style) = "titel" And ((aflijnsetting And 2) = 2) Then
                    GoTo nexfor
                ElseIf LCase$(srange.Style) = "titel_notis" And ((aflijnsetting And 2) = 2) Then
                    GoTo nexfor
                ElseIf LCase$(srange.Style) = "nietaflijnen" And ((aflijnsetting And 2) = 2) Then
                    GoTo nexfor
                ElseIf LCase$(srange.Style) = "subtitel" And ((aflijnsetting And 4) = 4) Then
                    GoTo nexfor
                ElseIf LCase$(srange.Style) = "info" And ((aflijnsetting And 8) = 8) Then
                    GoTo nexfor
                ElseIf LCase$(srange.Style) = "versie" And ((aflijnsetting And 16) = 16) Then
                    GoTo nexfor
                ElseIf aanhalen = True Then
                    srange.Text = Chr(132): inserts = inserts + 1
                End If
            
                eoffset = eols(I) + inserts
                If eoffset = 0 Then eoffset = 1
                Set MyRange = .Range(eoffset - 1, eoffset)
                          
                If ((LCase$(MyRange.Style) = "afsluiting") Or (LCase$(MyRange.Style) = "afsluiting_notis")) Then
                    Set afsluitingrange = MyRange.Duplicate
                    With afsluitingrange
                        .Collapse wdCollapseEnd
                        .MoveEnd wdCharacter, 1
                    End With
                    If Asc(afsluitingrange.Text) = 13 Then
                        With afsluitingrange
                            .Collapse wdCollapseStart
                            .MoveStart wdWord, -1
                        End With
                        If afsluitingrange.Text = "om" Then
                            With afsluitingrange
                                .Collapse wdCollapseEnd
                                posi = .Information(wdHorizontalPositionRelativeToTextBoundary)
                                With ActiveDocument.PageSetup
                                    lm = .LeftMargin
                                    rm = .RightMargin
                                    breed = .PageWidth
                                End With
                                lins = .ParagraphFormat.LeftIndent
                                rins = .ParagraphFormat.RightIndent
                                ruimte = (breed - lm - rm - lins - rins)
                            End With
                            
                            If (posi / ruimte) > 0.25 Then
                                afsluitingrange.InsertBreak (wdLineBreak)
                                inserts = inserts + 1
                            End If
                            GoTo nexfor
                        End If
                    End If
                End If
                t$ = MyRange.Text
                If t$ = " " Then 'spatie
                    If aanhalen = True Then
                        MyRange.Text = Chr(148) + uittab$(1): inserts = inserts + 2
                        MyRange.Start = MyRange.Start + 1
                    Else
                        If Left$(MyRange.Style, 5) = "verd_" Then
                            tabjes = NumOfTabs(MyRange)
                            MyRange.Text = uittab$(tabjes)
                            inserts = inserts + tabjes
                        Else
                            MyRange.Text = uittab$(1): inserts = inserts + 1
                        End If
                    End If
                ElseIf t$ = Chr(31) Then
                    If aanhalen = True Then
                        MyRange.Text = "-" + Chr(148) + uittab$(1): inserts = inserts + 3
                        MyRange.Start = MyRange.Start + 2
                    Else
                        If Left$(MyRange.Style, 5) = "verd_" Then
                            tabjes = NumOfTabs(MyRange)
                            MyRange.Text = afbreek$(tabjes)
                            inserts = inserts + tabjes + 1
                            MyRange.Start = MyRange.Start + 1
                        Else
                            MyRange.Text = afbreek$(1)
                            inserts = inserts + 2
                            MyRange.Start = MyRange.Start + tabjes
                        End If
                    End If
                ElseIf t$ > " " Then
                    If eols(I) - eols(I - 1) > 1 Then
                        If aanhalen = True Then
                            MyRange.InsertAfter Chr(148) + metab$(1): inserts = inserts + 2
                        Else
                            If Left$(MyRange.Style, 5) = "verd_" Then
                                tabjes = NumOfTabs(MyRange)
                                MyRange.InsertAfter metab$(tabjes)
                                inserts = inserts + tabjes
                            Else
                                MyRange.InsertAfter metab$(1)
                                inserts = inserts + 1
                            End If
                        End If
                        MyRange.Start = MyRange.End
                        MyRange.End = MyRange.Start + tabjes
                        t$ = MyRange.Text
                        If t$ > " " Then
                            MyRange.InsertBefore Chr(11)
                            inserts = inserts + 1
                        ElseIf aanhalen = True Then
                            x = MyRange.Font.size
                            yv = MyRange.ParagraphFormat.RightIndent
                            MyRange.ParagraphFormat.RightIndent = Fix(yv + 1 - 1.5 * x)
                        End If
                        MyRange.Start = MyRange.Start - tabjes
                    Else
                        GoTo nexfor
                    End If
                End If
                MyRange.End = MyRange.Start + tabjes
                If tabjes > 0 Then MyRange.Font = ft
    nexfor:
            Next I
            .UndoClear
        End With
        
        
        
        ActiveWindow.View.ShowHiddenText = bHiddenText
        
        strSettingTestAflijnenOffice2010 = FastLookUp("systeem", "IDVALUE", "ID = 'TestOffice2010Aflijnen'")
        If (strSettingTestAflijnenOffice2010 <> "-1") Then
            ActiveWindow.View.Type = viewtype
        End If
        
        Application.ScreenUpdating = True
        
    End Sub 'voeruit()

    '//*    Naam        : NumOfTabs(tabrange As Range) As Integer
    '       Functie     :
    '//*    Versie      : Original
    Private Function NumOfTabs(tabrange As Range) As Integer
        
        Dim pos As Long
        Dim I As Integer
        Dim gotit As Integer
        
        pos = tabrange.Information(wdHorizontalPositionRelativeToTextBoundary)
        Dim tabposi As tabstop
        For Each tabposi In tabrange.ParagraphFormat.TabStops
            If tabposi.Position > pos Then
                I = I + 1
                If tabposi.Alignment = wdAlignTabRight Then gotit = I: Exit For
            End If
        Next
        NumOfTabs = gotit
        
    End Function 'NumOfTabs(tabrange As Range) As Integer

    '//*    Naam        : AflijnenCurrentPage()
    '       Functie     :
    '//*    Versie      : Original
    Public Sub AflijnenCurrentPage()

        Dim p As Long
        
        p = Selection.Information(wdActiveEndPageNumber)
        Call init: Call CurrentPage(p): Call voeruit

    End Sub 'AflijnenCurrentPage()

    '//*    Naam        : AflijnenCurrentDoc()
    '       Functie     :
    '//*    Versie      : Original
    Public Sub AflijnenCurrentDoc()
        Dim starttime As Double
        Dim endtime As Double
            
        Dim t$
            
        starttime = Now
        Call init
        Call wholepage
        Call voeruit
        endtime = Now: t$ = Format((endtime - starttime) * 100000, "###.##")
        MsgBox "Duur aflijnen: " + t$ + " s  "
    End Sub 'AflijnenCurrentDoc()

    Wednesday, March 18, 2020 12:15 PM

All replies

  • Just a thought: Do you have the same printer setup on both your test systems?

    Word methods that access information about pagination and page setup (such as the .Information function calls) may perform differently depending on the overall printer setup (e.g. printer type, whether the printer is local or remote etc.)


    Peter Jamieson

    Thursday, March 19, 2020 12:42 AM
  • We have the same printer setup. 

    I have simplified the code. The init function is done in milliseconds in 2010. In 2019 it will take 1.16 sec. The call which takes a lot of time is 

    For Each sty In .Styles

    Next

    If I add this code (without depending code in the For..Next loop) in 2019 it will be very slow compared with 2010 

    Thursday, March 19, 2020 8:03 AM
  • Unfortunately, so far I have not been able to replicate such a big difference here.

    Using a loop like this:

    For Each sty In ActiveDocument.Styles
      Debug.Print ;
    Next

    with an empty document, Word 2019 took about 3 times as long as Word 2010 to process its styles (2019 processed 373 styles and 2010 processed 264). The machines are both Virtual Machines (Win 10 for 2019 and Win7 for 2010) so I cannot even really be sure that the differences are because of Word and not Windows or something to do with the VM.

     


    Peter Jamieson

    Thursday, March 19, 2020 6:29 PM