Code for replacing underlined text with underlined blanks througho

[vcube]

Appreciate if the gurus here can show me some way out here. My problem
statement is simple.
* I am creating a pub file with many pages, with each page containing many
objects including TEXT boxes. Text boxes contain text and some of the
words are underlined.
* I would like to run a macro which can replace ALL the UNDERLINED text to
UNDERLINED spaces. This would help me create two pub files, with one file
containing the filled text and the other where words need to be filled in.

Currently I am doing it manually, and this is taking a lot of time, and not
to speak of maintaining TWO files unnecessarily.

Thanks beforehand for the code snippet!

 

[vcube]

Sorry, it is best explained with an example as well:

Text: This is an <ul> example </ul> line
After replace: This is an ___________ line

(In the above <ul> </ul> represents UNDERLINED text in PUB 2003)
Thanks

 

[Ed Bennett]

Sorry, it is best explained with an example as well:

Text: This is an <ul> example </ul> line
After replace: This is an ___________ line

If you want a monospaced underline (e.g. using underscores), this will
be rather easier than if you want an underline the same width as the
text would have been. Underlined spaces would be very deficient in width.

 

[vcube]

Hi Ed: Thanks for your clarification. You are correct. It should be
UNDERSCORES rather than underlining spaces.

As you can guess, I am still looking for that programmable (macro) code!
I am hoping this can save me lots of pain and time by replacing all
underlined text with underscores in all pub pages. Thanks again for your
time.

 

[Ed Bennett]

As you can guess, I am still looking for that programmable (macro) code!
I am hoping this can save me lots of pain and time by replacing all
underlined text with underscores in all pub pages. Thanks again for your
time.

Hi vcube,

Here's the code:

'**********************
Sub ReplaceUnderlines()
ThisDocument.BeginCustomUndoAction _
"Replace underlines with underscores"
Dim ashape As Shape
Dim apage As Page
Dim i As Long

For Each apage In ThisDocument.Pages
For Each ashape In apage.Shapes
If ashape.HasTextFrame = msoTrue Then
With ashape.TextFrame.TextRange
For i = 1 To .Length
If (Not .Characters(i).Font.Underline = _
pbUnderlineNone) And Not (.Characters(i).Text _
= Chr$(13)) Then

.Characters(i).Font.Underline = pbUnderlineNone
.Characters(i).InsertAfter ("_")
.Characters(i).Delete
End If
Next
End With
End If
Next
Next
ThisDocument.EndCustomUndoAction
End Sub
'**********************

Thanks again for your
time.

I normally charge for it for writing complete macros, but this one took
my interest, and it was your first time.

 

[vcube]

Hi Ed:

Thanks a lot! This rocks!!

Hi vcube,

Here's the code:

'**********************
Sub ReplaceUnderlines()
ThisDocument.BeginCustomUndoAction _
"Replace underlines with underscores"
Dim ashape As Shape
Dim apage As Page
Dim i As Long

For Each apage In ThisDocument.Pages
For Each ashape In apage.Shapes
If ashape.HasTextFrame = msoTrue Then
With ashape.TextFrame.TextRange
For i = 1 To .Length
If (Not .Characters(i).Font.Underline = _
pbUnderlineNone) And Not (.Characters(i).Text _
= Chr$(13)) Then

.Characters(i).Font.Underline = pbUnderlineNone
.Characters(i).InsertAfter ("_")
.Characters(i).Delete
End If
Next
End With
End If
Next
Next
ThisDocument.EndCustomUndoAction
End Sub
'**********************


I normally charge for it for writing complete macros, but this one took
my interest, and it was your first time.

 

[Ed Bennett]

Thanks a lot! This rocks!!

Glad to be of service