Text find/selection problem in textboxes

D

David Turner

I have some code which attempts to tidy up Word documents converted from or
pasted from PDF so that the text wraps correctly without hard returns at the
ends of lines.
It basically does a wildcard search for lines not ending in stop
punctuation (.,:;?!) and beginning with a lower case letter on the next line.
It should thus find lines like:
The quick red fox[hard/soft return]
jumped over the lazy brown cow
then remove the hard/soft return and add a space to wrap the text onto one
line.
I've also tried to arrange for it to ignore any bulleted lines
(ListParagraphs) lines starting with a lower case letter.
The code seems to work OK in the body of the document but fails for some
reason in text boxes. The text is selected but then the selection moves
outside the text box.
Can anyone see what's going wrong?
Any help would be greatly appreciated.
Thanks.

Sub PDFTidy()

Dim rDoc As Range
Dim rTmp As Range
Dim rShp As Range
Dim pos1 As Long
Dim pos2 As Long
Dim sTmp As String
Dim pText As String
Dim iShpCnt As Long

pText = "([!^13^l\.\:\;\!\?])[^13^l]([a-z])"

Set rDoc = ActiveDocument.Range
Set rTmp = Selection.Range
With rDoc.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = pText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
While .Execute
pos1 = rDoc.Start
rTmp.Start = pos1
pos2 = rDoc.End
rTmp.End = pos2
rTmp.Select
Selection.Collapse Direction:=wdCollapseEnd
If Selection.Paragraphs(1).Range.ListParagraphs.Count = 0 Then
Selection.Start = pos1
rTmp.Select 'for testing [F8]
sTmp = rTmp.Text
sTmp = Replace(sTmp, vbCr, " ")
rTmp.Text = sTmp
End If
rDoc.Collapse Direction:=wdCollapseEnd
rDoc.End = ActiveDocument.Range.End
Wend
End With

For iShpCnt = ActiveDocument.Shapes.Count To 1 Step -1
With ActiveDocument.Shapes(iShpCnt)
If .Type = msoTextBox Then
If ActiveDocument.Shapes(iShpCnt).TextFrame.HasText = True
Then
Set rShp =
ActiveDocument.Shapes(iShpCnt).TextFrame.TextRange
MsgBox
ActiveDocument.Shapes(iShpCnt).TextFrame.TextRange.Text
'rShp.Select
With rShp.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = pText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
While .Execute
pos1 = rShp.Start
rTmp.Start = pos1
pos2 = rShp.End
rTmp.End = pos2
rTmp.Select ; Code fails here: the selection is
outside the text box
Selection.Collapse Direction:=wdCollapseEnd
If
Selection.Paragraphs(1).Range.ListParagraphs.Count = 0 Then
Selection.Start = pos1
rTmp.Select 'for testing [F8]
sTmp = rTmp.Text
sTmp = Replace(sTmp, vbCr, " ")
rTmp.Text = sTmp
End If
rShp.Collapse Direction:=wdCollapseEnd
Wend
End With
End If
End If
End With
Next iShpCnt

End Sub
 
L

Lene Fredborg

The problem is that - in the code that treats the shapes - rTmp has not been
redefined to the range of the text box. This means that Pos1 and Pos2 will be
those positions in the wrong range.

The code should work if you insert the following line just after the “While
..Execute†line:

Set rTmp = rShp

Also, at the end of the macro, you should include code where you set each
range you have “Set†back to nothing, e.g.

Set rShp = Nothing

--
Regards
Lene Fredborg - Microsoft MVP (Word)
DocTools - Denmark
www.thedoctools.com
Document automation - add-ins, macros and templates for Microsoft Word


David Turner said:
I have some code which attempts to tidy up Word documents converted from or
pasted from PDF so that the text wraps correctly without hard returns at the
ends of lines.
It basically does a wildcard search for lines not ending in stop
punctuation (.,:;?!) and beginning with a lower case letter on the next line.
It should thus find lines like:
The quick red fox[hard/soft return]
jumped over the lazy brown cow
then remove the hard/soft return and add a space to wrap the text onto one
line.
I've also tried to arrange for it to ignore any bulleted lines
(ListParagraphs) lines starting with a lower case letter.
The code seems to work OK in the body of the document but fails for some
reason in text boxes. The text is selected but then the selection moves
outside the text box.
Can anyone see what's going wrong?
Any help would be greatly appreciated.
Thanks.

Sub PDFTidy()

Dim rDoc As Range
Dim rTmp As Range
Dim rShp As Range
Dim pos1 As Long
Dim pos2 As Long
Dim sTmp As String
Dim pText As String
Dim iShpCnt As Long

pText = "([!^13^l\.\:\;\!\?])[^13^l]([a-z])"

Set rDoc = ActiveDocument.Range
Set rTmp = Selection.Range
With rDoc.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = pText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
While .Execute
pos1 = rDoc.Start
rTmp.Start = pos1
pos2 = rDoc.End
rTmp.End = pos2
rTmp.Select
Selection.Collapse Direction:=wdCollapseEnd
If Selection.Paragraphs(1).Range.ListParagraphs.Count = 0 Then
Selection.Start = pos1
rTmp.Select 'for testing [F8]
sTmp = rTmp.Text
sTmp = Replace(sTmp, vbCr, " ")
rTmp.Text = sTmp
End If
rDoc.Collapse Direction:=wdCollapseEnd
rDoc.End = ActiveDocument.Range.End
Wend
End With

For iShpCnt = ActiveDocument.Shapes.Count To 1 Step -1
With ActiveDocument.Shapes(iShpCnt)
If .Type = msoTextBox Then
If ActiveDocument.Shapes(iShpCnt).TextFrame.HasText = True
Then
Set rShp =
ActiveDocument.Shapes(iShpCnt).TextFrame.TextRange
MsgBox
ActiveDocument.Shapes(iShpCnt).TextFrame.TextRange.Text
'rShp.Select
With rShp.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = pText
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
While .Execute
pos1 = rShp.Start
rTmp.Start = pos1
pos2 = rShp.End
rTmp.End = pos2
rTmp.Select ; Code fails here: the selection is
outside the text box
Selection.Collapse Direction:=wdCollapseEnd
If
Selection.Paragraphs(1).Range.ListParagraphs.Count = 0 Then
Selection.Start = pos1
rTmp.Select 'for testing [F8]
sTmp = rTmp.Text
sTmp = Replace(sTmp, vbCr, " ")
rTmp.Text = sTmp
End If
rShp.Collapse Direction:=wdCollapseEnd
Wend
End With
End If
End If
End With
Next iShpCnt

End Sub
Click to expand...
 
D

David Turner

That was it. The code seems to be working perfectly now. Many thanks Lene.
 
L

Lene Fredborg

You are welcome. I am glad I could help.

--
Regards
Lene Fredborg - Microsoft MVP (Word)
DocTools - Denmark
www.thedoctools.com
Document automation - add-ins, macros and templates for Microsoft Word
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Split Word doc into several files (continued) 3
Word Macro for multiple searches, incl. in footnotes 2
Need help modifying code 0
selecting text II 4
find / replace for only certain pages - Please see code 3
Export Block of Emails and Format to New Word doc 1
Modify maco - extract definition 1st then acronym within ( ) 5
Replacing Text w/Autotext - Greg, Ed, Graham,Russ 19

Top