Changing the names of text boxes

catflap · #1 05-08-2018, 07:47 AM

Looks interesting - I'll give it a go.

I've also being playing with Libre Office and that seems to have a 'fit text to frame' option, so that might be worth testing as well.

Cheers

UPDATE: Libre Office is a no-go. Writer will resize text to fit, but it doesn't work with merged text. I can't believe this is so difficult to achieve!

catflap · #2 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"

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Formats in text boxes in Word 2016 changing unexpectedly	PugwashAtNPEU	Word	4	05-04-2017 05:53 AM
Changing Default Fonts for Text Boxes and Tables	LadyBug679	PowerPoint	2	04-01-2016 06:42 AM
Changing the font colour in all text boxes	marqives	Word VBA	1	11-25-2014 06:05 PM
Changing the placeholder text for drop down boxes	DeadBatteries	Word	1	08-24-2012 09:09 AM
Arrows and text boxes disappear when changing view?	Jesse	Word	4	06-12-2012 05:28 PM