From recorded tro rational

Ulodesk · #1 02-05-2022, 12:24 PM

Hello. I have recorded the following multi-stage macro. I know that it's longer than needed but have really no idea what I can safely remove. Would one of you experts be kind enough to trim it down for me? Thank you very much.

Code:

Sub PreEdit()
'
' Macro to replace in the entire document:
' straight single and double straight quotes with curly;
' remove tabs;
' replace manual line returns with hard returns; and
' remove empty paragraphs
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "'"
        .Replacement.Text = "'"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = """"
        .Replacement.Text = """"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^l"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

gmayor · #2 02-06-2022, 02:23 AM

If it ain't broke - don't fix it! However I would probably do it as follows. Depending on the document, you may have to address all the story ranges. This just accesses the document body.

Code:

Sub ReplaceQuotes()
' Macro to replace in the entire document:
' straight single and double straight quotes with curly
Dim sFormat As Boolean
    sFormat = Options.AutoFormatAsYouTypeReplaceQuotes
    Options.AutoFormatReplaceQuotes = True
    ActiveDocument.Range.AutoFormat
     Options.AutoFormatAsYouTypeReplaceQuotes = sFormat
   ' Call the FixSpace sub
     FixSpace ActiveDocument.Range 
lbl_Exit:
    Exit Sub
End Sub

Private Sub FixSpace(oRng As Range)
' remove tabs;
' replace manual line returns with hard returns; and
' remove empty paragraphs
Dim oFind As Range
    Set oFind = oRng.Duplicate
    With oFind.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^t"
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
    End With
    Set oFind = oRng.Duplicate
    With oFind.Find
        .Text = "^l"
        .Replacement.Text = "^p"
        .Execute Replace:=wdReplaceAll
    End With
    With oFind.Find
        .Text = "^13{1,}"
        .Replacement.Text = "^p"
        .Execute MatchWildcards:=True, Replace:=wdReplaceAll
    End With
End Sub

Ulodesk · #3 02-06-2022, 09:38 AM

Graham, thank you very much. However, I'm afraid I don't know what you mean by "all the story ranges." Story is apparently a VBA term that means something particular, less than "document body." Although all the documents on which this is likely to be used is have only one Word section (if that is relevant), how would your version not work on the whole document?

Thank you.

gmayor · #4 02-06-2022, 11:27 PM

Word documents are made up of several story ranges. Imagine if you will a pile of transparencies, each containing part of the document.

The principle story range is the ActiveDocument.Range which contains all the text in the document body. However the document may have headers/footers/text boxes/tables/graphics etc. If these are relevant, you would need to amend the code to loop through all the available story ranges. Unfortunately that won't work for autoformat. The following will loop through the ranges and call FixSpace. You may still find it necessary to address issues on an individual basis by adding to he FixSpace macro. Much depends on the complexity of the document.

Code:

Sub Find_Replace()
Dim oDoc As Document
Dim oShp As Shape
Dim sFormat As Boolean
Dim oStory As Range
    
    Set oDoc = ActiveDocument
    sFormat = Options.AutoFormatAsYouTypeReplaceQuotes
    Options.AutoFormatReplaceQuotes = True
    oDoc.Range.AutoFormat
    Options.AutoFormatAsYouTypeReplaceQuotes = sFormat
    
    For Each oStory In oDoc.StoryRanges
        Select Case oStory.StoryType
            Case 1 To 11
                Do
                    FixSpace oStory
                    DoEvents
                    Select Case oStory.StoryType
                        Case 6, 7, 8, 9, 10, 11
                            If oStory.ShapeRange.Count > 0 Then
                                For Each oShp In oStory.ShapeRange
                                    If oShp.TextFrame.HasText Then
                                        FixSpace oShp.TextFrame.TextRange
                                    End If
                                    DoEvents
                                Next oShp
                            End If
                        Case Else
                            'Do Nothing
                    End Select
                    'Get next linked story (if any)
                    Set oStory = oStory.NextStoryRange
                Loop Until oStory Is Nothing
            Case Else
        End Select
        DoEvents
    Next oStory
lbl_Exit:
    Set oStory = Nothing
    Set oDoc = Nothing
    Exit Sub
End Sub

Ulodesk · #5 02-07-2022, 06:16 AM

I see. Thank you again.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Please help! Macros not recorded as expected	Chibiberu	Word VBA	4	03-30-2019 02:42 AM
Modify recorded macro to run until end of document	peter961	Word VBA	1	09-04-2017 02:50 PM
Embedded Video Not Playing in Recorded Presentation	bhadden1	PowerPoint	0	08-16-2017 03:07 PM
Add previously recorded sound and synchronize with slide annimations	daniellouw	PowerPoint	1	03-03-2017 11:14 AM
Can I record more to add on to a recorded Macro?	Clueless in Seattle	Word VBA	3	05-25-2015 01:21 AM