Sub to set minimum font in Word stops responding in (large, or something else?) documents RRS feed

  • Question

  • I have a sub that I kluged together from the internet. It is to set a minimumfont on a word document. I tested it on a basic Word document with different font sizes. It works as intended, however when I run it on a more complex and larger document it ceases to respond. I have to crash Word to halt it. I have determined that

    ActiveDocument.Range.Characters.Count is roughly 24000 char for the problem document. Could this just be an ineffecient search on a large document or could something in the (Tables, Header/Footer, or something else) be causing the problem? Can I get the same result another way? Here is the code:

    Private Sub CommandButton22_Click()
    ' sets minimum font size to ZZ
    ZZ = TextBox15.Text
    For i = 1 To ActiveDocument.Range.Characters.Count
        If ActiveDocument.Range.Characters(i).Font.Size < ZZ Then
            ActiveDocument.Range.Characters(i).Font.Size = ZZ
        End If
    End Sub

    Any assistance would be appreciated.


    Wednesday, September 26, 2012 5:16 PM

All replies

  • I suggest you to change the styles of the document instead changing each character's font size:

    Sub Example()
        Const lMinimum = 10 '<--- change to suit
        Dim st As Style
        For Each st In ActiveDocument.Styles
            If st.Font.Size < lMinimum Then
                st.Font.Size = lMinimum
            End If
        Next st
    End Sub

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Tuesday, October 2, 2012 9:48 PM
  • Thanks for the response Felipe. I was able to get this answer on another forum.

    Private Sub CommandButton22_Click()
         ' sets minimum font size
    If Not IsNumeric(TextBox15.Text) Then Exit Sub
    If (TextBox15.Text < 1) Or (TextBox15.Text > 72) Then Exit Sub
    '    input validation
        Application.ScreenUpdating = False
        Dim i As Long
        With ActiveDocument.Content.Find
            With .Replacement
                .Text = ""
                .Font.Size = TextBox15.Text
            End With
            .Format = True
            .Text = ""
            .Wrap = wdFindContinue
            For i = 2 To TextBox15.Text * 2 - 1
                .Font.Size = i / 2
                .Execute Replace:=wdReplaceAll
                If i Mod 100 = 0 Then DoEvents
    '           Chunk the operation
        End With
        Application.ScreenUpdating = True
    End Sub

    I will try your solution as well. Styles were suggested initially but were abandoned when I explained that these documents come from clients with very mangled styles. How would your solution work with lots of cut and paste from multiple sources?


    Tuesday, October 9, 2012 6:37 PM
  • Could you post the link of the another forum?

    "How would your solution work with lots of cut and paste from multiple sources?"
    How this cut and paste happens? Manually?
    In a short answer, I would just cut and paste everything and then change the styles' font size.

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Tuesday, October 9, 2012 9:35 PM
  • Here is the link


    I assume that the documents would be created with lots of pasting from all different sources. Most people do not worry about styles they are importing doing that. There could be multiple Heading 1's etc. Your solution will not have a problem coping with that? Will it change the normal/unformatted style?



    Wednesday, October 10, 2012 9:40 PM
  • Yes, it could have a problem if you ran my code, but I believe if you select your entire document and press Ctrl+Space Bar, all styles will be redefined and then you can run my macro.

    By the way, did the solution you got from the other forum work?

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    Wednesday, October 17, 2012 1:01 AM
  • Felipe

         It seems to work well. It is much faster than what I had come up with. I even let them twist my arm into putting input validation in. I have not tested your solution, but I will.


    Friday, October 19, 2012 8:34 PM