Microsoft Office Forums - View Single Post - [Solved] Changing the names of text boxes

catflap · 05-09-2018, 07:47 AM

I've just done a few speed trials. This is based on just 1 run of each category, so environmental factors could be having an influence.

This is running the 'shrink to fit' vba on a document of 100 pages.

Loop through only: 8 seconds
Shrink to fit on my original code: 80 seconds
Shrink to fit using the Alternative text idea to 'flag' text boxes from Guessed: 43 seconds

So there's been a definite improvement - thanks for the idea.

I now need to keep looking at this to see how much nearer I can get to the 8 seconds, which is literally looping through and doing nothing else that I'm going to use as a theoretical maximum speed!

Here's the latest code:

Code:

    Dim oShp As Shape
    Dim changecount As Integer
    Dim shapecount, shapemax, pcount, allpages, pagetemp As Long
    Dim Doc As Document
    Dim sbar As Boolean
    Dim timestart, timstop As Date
    
    timestart = Now()
    
    shapecount = 1
    shapemax = ActiveDocument.Shapes.Count
    
    Application.ScreenUpdating = False
    sbar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    
    pagetemp = 0
    changecount = 0
    allpages = ActiveDocument.Range.Information(wdNumberOfPagesInDocument)
    
    For Each oShp In ActiveDocument.Shapes

        If oShp.Type = msoTextBox Then
                   
            If ActiveDocument.Shapes(oShp.Name).TextFrame.Overflowing Then
                If ActiveDocument.Shapes(oShp.Name).AlternativeText = "Shrink" Then
                               
                    Do While ActiveDocument.Shapes(oShp.Name).TextFrame.Overflowing
                        ActiveDocument.Shapes(oShp.Name).TextFrame.TextRange.Font.Shrink
                    Loop
                    changecount = changecount + 1
                    
                End If
           End If
            
        End If
        
        pcount = oShp.Anchor.Information(wdActiveEndPageNumber)
        
        If pagetemp <> pcount Then
            StatusBar = "                                                                                                                                            COMPLETE: " & pcount & " / " & allpages
            pagetemp = pcount
        End If
        
        DoEvents
        shapecount = shapecount + 1
        
    Next
    
    Application.StatusBar = False
    Application.DisplayStatusBar = sbar
    Application.ScreenUpdating = True
    
    timestop = Now()

    MsgBox "Complete - " & changecount & " changes made. Time taken: " & DateDiff("s", timestart, timestop) & " seconds"