#16
|
||||
|
||||
Hmmm. I've been playing around with this some more and I now can't beat 31 seconds.
I'm beginning to think I must have made some sort of mistake on the 20 seconds run, but in case it helps anyone, here's the code as it now stands: Code:
Dim oShp As Shape Dim changecount As Integer Dim shapecount, shapemax As Long Dim Doc As Document Dim sbar As Boolean Dim timestart, timstop As Date Dim changeflag As Boolean timestart = Now() shapecount = 1 shapemax = ActiveDocument.Shapes.Count Application.ScreenUpdating = False Application.DisplayStatusBar = True changecount = 0 changeflag = False allshapes = ActiveDocument.Shapes.Count For Each oShp In ActiveDocument.Shapes With oShp.TextFrame If oShp.AlternativeText = "shrink" Then Do While .Overflowing changeflag = True .TextRange.Font.Shrink DoEvents Loop If changeflag = True Then changecount = changecount + 1 changeflag = False End If StatusBar = " COMPLETE: " & shapecount & " / " & allshapes DoEvents shapecount = shapecount + 1 End With Next oShp Application.ScreenUpdating = True timestop = Now() MsgBox "Complete - " & changecount & " changes made. Time taken: " & DateDiff("s", timestart, timestop) & " seconds" Thanks everyone for the input - I've learnt a lot from doing this and it's an improvement on the original. |
#17
|
||||
|
||||
Just tidying the logic a little bit and changing the activewindow view. Is this any different in speed?
Code:
Sub SpeedTest() Dim oShp As Shape, changecount As Integer, shapecount As Long, shapemax As Long Dim timestart As Date, timestop As Date, changeflag As Boolean timestart = Now() shapemax = ActiveDocument.Shapes.Count Application.ScreenUpdating = False ActiveWindow.View = wdNormalView changeflag = False For Each oShp In ActiveDocument.Shapes changeflag = False If oShp.AlternativeText = "shrink" Then With oShp.TextFrame Do While .Overflowing changeflag = True .TextRange.Font.Shrink DoEvents Loop End With If changeflag = True Then changecount = changecount + 1 StatusBar = String(50, " ") & "Macro status: " & shapecount & " of " & AllShapes shapecount = shapecount + 1 End If Next oShp ActiveWindow.View = wdPrintView Application.ScreenUpdating = True timestop = Now() MsgBox "Complete - " & changecount & " changes made. Time taken: " & DateDiff("s", timestart, timestop) & " seconds" End Sub Dim shapecount, shapemax As Long gives you shapecount as a variant and shapemax as Long
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#18
|
||||
|
||||
Hi Guessed
Thanks for posting again - really appreciate your input. First run your code through seemed a little slower at 48 seconds for the 100 test records, then I ran it again and it came up as 28 seconds! I guess the process is just massively skewed by environmental factors (ie what else the PC is doing) and I'm going to have to do several more tests and use larger numbers of records and then see what the results are. I've not seen this degree of variance in vba code before, but I guess I'm not usually so concerned with speed. 2 oddities with your code which I can't quite explain: 1. the status bar update text doesn't buff out 50 spaces from the edge, it just sits the code to the left hand side of the screen. 2. The shrink never seems to tackle the first text box it finds - it always skips that but does the rest - weird! Anyway, I'll do some more tests tomorrow and post my results. |
#19
|
||||
|
||||
If you are getting variance like that then it is pretty pointless pursuing incremental gains in speed unless you are running this 10+ times a day. However it is always worth learning more efficient ways of coding.
I don't know why the status bar push isn't working (it does work on my machine) but perhaps you could try other characters. eg StatusBar = String(50, Chr(151)) & "Macro status: " & shapecount & " of " & AllShapes StatusBar = String(50, Chr(160)) & "Macro status: " & shapecount & " of " & AllShapes StatusBar = String(50, "_") & "Macro status: " & shapecount & " of " & AllShapes My guess is that the problem with the first text box being missed is that the alt text is not EXACTLY correct. A space either before or after the visible text would be enough to skip over it. Try this as a modification to avoid that type of issue If Trim(LCase(oShp.AlternativeText)) = "shrink" Then
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#20
|
||||
|
||||
Hi
I'll try those. The alt text thing can't be a naming discrepancy though, as the merge would have created all boxes in the 100 record doc from the same alt text as the original merge doc? - I will check this though. Last edited by catflap; 05-11-2018 at 06:48 AM. |
#21
|
||||
|
||||
Hi Guessed
Here are the results of running the macro 5 times on a document of 500 pages: Speedtest macro: 1) 216 seconds 2) 670 seconds 3) 572 seconds 4) 285 seconds 5) 458 seconds Average: 440 seconds Previous macro: 1) 799 seconds 2) 498 seconds 3) 629 seconds 4) 525 seconds 5) 500 seconds Average: 590 seconds So your latest code is definitely faster, but there's still a huge amount of variation in process time going on. Interesting what you mentioned about dimensioning as well - I always thought that putting the 2 variants in the same line: Dim shapecount, shapemax As Long ...would dim both as Long, so I've learned something new there. By the way, I don't do these jobs every day, but when I do I often have 10 or more docs of 1000 pages each to do, so it's definitely worth me trying to shave as much time off the process as possible. |
Thread Tools | |
Display Modes | |
|
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 |