Consulting

Results 1 to 20 of 20

Thread: format paragraph where font size is greater than set value

  1. #1
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location

    format paragraph where font size is greater than set value

    Hi,
    Is it possible to format paragraph where font size is greater than set value. e.g. set value = 15 and code changing paragraph where font size = 20 or 25 or 50... but not change paragraphs where font size = 14 or 9...


    Sub xml_test()
    '
    ' xml_test
    '
    '
        Selection.Find.ClearFormatting
        With Selection.Find.Font
            .Size = 15
            .bold = False
            .Italic = False
        End With
        With Selection.Find.ParagraphFormat
            .Alignment = wdAlignParagraphJustify
        End With
        
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ""
            .Replacement.Text = "<Title>^&</Title>"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
             End With
        Selection.Find.Execute Replace:=wdReplaceAll
    End Sub

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Sub Test()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        While .Execute
          If oRng.Font.Size > 14 Then
            'Do something here.
          End If
        Wend
      End With
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    It is never ending loop:

    Sub Title_xml()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        Do While .Execute
          If oRng.Font.Size > 14 Then
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
          End If
       Wend
      End With
    End Sub

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Collapsethe rangeto it’s end after your two sreps
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    Ok it works but it is formatting only one first paragraph where font size is greater than 14, I want to format all paragraphs in document.

    Sub Title_xml()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        Do While .Execute
          If oRng.Font.Size > 14 Then
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
          End If
        Exit Do
        Loop
      End With
    End Sub

  6. #6
    Remove the line
    Exit Do
    which limits the search to the first instance.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    Quote Originally Posted by gmayor View Post
    Remove the line
    Exit Do
    which limits the search to the first instance.
    no, back to infinite loop

  8. #8
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    This code ran here on a simple sample document runs and works without a continuous loop. Send a sample your having trouble with:

    Sub Title_xml()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        Do While .Execute
          If oRng.Font.Size > 14 Then
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
          End If
        Loop
      End With
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  9. #9
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    Lorem ipsum dolor sit amet.docx
    It happens when in document are two empty paragraphs with font size bigger than 14, I know that it is wrong formatting of document and should be no empty paragraphs, but I receive it like this one, and maybe it is better to put a part of code wich will ignore empty paragraphs or remove empty paragraphs like this one below, I don't know what is better:

    Sub delete_empty_paragraph()
         Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "^p^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    End Sub

  10. #10
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    The code I provided earlier does not continuously loop here even with two empty paragraphs with font larger than 14 points. But, this might be more what you are looking to do:

    Sub Title_xml()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        Do While .Execute
          If oRng.Font.Size > 14 Then
            oRng.End = oRng.End - 1
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
            oRng.End = oRng.End + 1
          End If
        Loop
      End With
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  11. #11
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Do note that Greg's code won't process paragraphs with mixed font sizes, which could occur with run-in headings.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  12. #12
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    Quote Originally Posted by macropod View Post
    Do note that Greg's code won't process paragraphs with mixed font sizes, which could occur with run-in headings.
    Paul, that situation will not gonna happen with my documents - every time the same font size. Example document still have infinite loop, I really don't know why.


    Greg's code working without infinite loop but added my tags to empty paragraphs but probably i found a solution, please check it:

    Sub remove_empty_paragraph_xml()
    
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        Do While .Execute
          If oRng.Font.Size > 14 And Len(oRng.Paragraphs(1).Range.Text) > 1 Then
            oRng.End = oRng.End - 1
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
            oRng.End = oRng.End + 1
          End If
        Loop
      End With
    
    End Sub
    Last edited by dagerr; 11-02-2018 at 02:42 AM.

  13. #13
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    What example document? You have not posted an example document!
    Greg

    Visit my website: http://gregmaxey.com

  14. #14
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    Quote Originally Posted by gmaxey View Post
    What example document? You have not posted an example document!
    http://www.vbaexpress.com/forum/atta...4&d=1541073252
    Karol

  15. #15
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Sorry, about that.

    Sub Title_xml()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
          If oRng.Font.Size > 14 Then
            oRng.End = oRng.End - 1
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
            oRng.End = oRng.End + 1
          End If
        Loop
      End With
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  16. #16
    VBAX Regular
    Joined
    Jan 2018
    Posts
    58
    Location
    Quote Originally Posted by gmaxey View Post
    Sorry, about that.

    Sub Title_xml()
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        .Wrap = wdFindStop
        Do While .Execute
          If oRng.Font.Size > 14 Then
            oRng.End = oRng.End - 1
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
            oRng.End = oRng.End + 1
          End If
        Loop
      End With
    End Sub
    ok, no problem but still inserting on empty paragraphs. Look on mine code, I added one line and it is seems to be ok

    Sub remove_empty_paragraph_xml()
    
    Dim oRng As Range
      Set oRng = ActiveDocument.Range
      With oRng.Find
        .Text = "*^13"
        .Format = True
        .MatchWildcards = True
        Do While .Execute
          If oRng.Font.Size > 14 And Len(oRng.Paragraphs(1).Range.Text) > 1 Then 'added line
            oRng.End = oRng.End - 1
            oRng.InsertAfter "</Title>"
            oRng.InsertBefore "<Title>"
            oRng.Collapse wdCollapseEnd
            oRng.End = oRng.End + 1
          End If
        Loop
      End With
    
    End Sub
    Karol

  17. #17
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Well you need to add the .Wrap = wdFindStop to prevent the looping.
    Greg

    Visit my website: http://gregmaxey.com

  18. #18
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Try:
    Sub Demo()
    Application.ScreenUpdating = False
    Dim i As Long
    With ActiveDocument.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = True
        .Text = "(*)^13"
        .Replacement.Text = "<Title>\1</Title>^p"
        .MatchWildcards = True
        .Wrap = wdFindContinue
        For i = 29 To 144
          .Font.Size = i / 2
          .Execute Replace:=wdReplaceAll
        Next
      End With
    End With
    Application.ScreenUpdating = True
    End Sub
    The above code processes everything from 14.5pt to 72pt and, in a long document, may be much faster than looping through every paragraph. If you're confident that the point sizes lie within a narrower range, adjust the 29 and/or 144 accordingly for faster execution.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  19. #19
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Paul,

    That is still affecting the empty paragraphs. Maybe:

    Sub Demo()
    Application.ScreenUpdating = False
    Dim i As Long
    With ActiveDocument.Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Format = True
        .Text = "(*)^13"
        .Replacement.Text = "<Title>\1</Title>^p"
        .MatchWildcards = True
        .Wrap = wdFindContinue
        For i = 29 To 144
          .Font.Size = i / 2
          .Execute Replace:=wdReplaceAll
        Next
      End With
      With ActiveDocument.Range
        With .Find
          .ClearFormatting
          .Replacement.ClearFormatting
          .Forward = True
          .Format = True
          .Text = "<Title></Title>"
          .Replacement.Text = ""
          .Wrap = wdFindContinue
          .Execute Replace:=wdReplaceAll
        End With
      End With
    End With
    Application.ScreenUpdating = True
    End Sub
    ... this results in the addition of an empty paragraph at the end of the sample document. Don't know if that is problem or not.
    Greg

    Visit my website: http://gregmaxey.com

  20. #20
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Quote Originally Posted by gmaxey View Post
    That is still affecting the empty paragraphs.
    Granted, but one really shouldn't have such paragraphs in a properly-formatted document. As an alternative to your approach, one could change:
    .Text = "(*)^13"
    in the code I posted to:
    .Text = "([!^13]@)^13"
    This also avoids the empty last paragraph your code creates.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •