Word VBA Help Requested; Easy?

[htmldiva]

I found this code that extracts email addresses from the active word document. It works great, but can't figure out how to put the addresses at the end of the active document instead of a new document. Can you please tell me how to tweak it to get it to work?

---------------
Dim Source As Document, Target As Document, myRange As Range
Set Source = ActiveDocument
Set Target = Documents.Add
Source.Activate
Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findText:="[+0-9A-z._-]{1,}\@[A-z.]{1,}", MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
Set myRange = Selection.Range
Target.Range.InsertAfter myRange & "; "
Loop
End With
Selection.HomeKey Unit:=wdStory
Target.Activate

[gmaxey]

Something like this:

Sub ScratchMacroII()
'A basic Word macro coded by Greg Maxey
Dim oRngCurrent As Word.Range
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
Set oRngCurrent = oRng.Duplicate
oRngCurrent.MoveEnd wdCharacter, -1
With oRng.Find
.ClearFormatting
Do While .Execute(findText:="[+0-9A-z._-]{1,}\@[A-z.]{1,}", MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
If oRng.InRange(oRngCurrent) Then
ActiveDocument.Range.InsertAfter oRng & "; "
Else
Exit Sub
End If
Loop
End With
End Sub

[fumei]

Please use the VBA code tags.

Try:
Sub BlahBlahBlah()
Dim Source As Document
Dim r As Range
Dim strAddressList As String

Set Source = ActiveDocument
Set r = Source.Range
With r.Find
Do While .Execute(findText:="[+0-9A-z._-]{1,}\@[A-z.]{1,}", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
strAddressList = strAddressList & r.Text & "; "
Loop
End With
Source.Range.InsertAfter strAddressList
End Sub

The code uses the range (r) of the document to find the find. It then appends the string variable strAddressList with each address. You want to use a string because if you just built the end of the document with found address, then Find will find those new ones...and on and on forever. An infinite loop.

When all address are found (and the Find loop terminates), the code dumps the appended string at the end of the document.

[fumei]

Huh. Greg posted while I was writing. The two posts shows how you can get the same result with different code.

The biggest difference is that my code technically has a limit. The limit of how long a string can be. However, unless you are dealing with hundreds of thousands of emails, that is not an issue.

[gmaxey]

Gerry, both our codes leaves a dangling "; "

Your is easily fixed with:
Source.Range.InsertAfter Left(strAddressList, Len(strAddressList) - 2)

Fixing mine would take more effort that I don't want to fool with right now.

[fumei]

Doh! You of course correct, we do not want that last "; ".

[htmldiva]

Something like this:

Sub ScratchMacroII()
'A basic Word macro coded by Greg Maxey
Dim oRngCurrent As Word.Range
Dim oRng As Word.Range
Set oRng = ActiveDocument.Range
Set oRngCurrent = oRng.Duplicate
oRngCurrent.MoveEnd wdCharacter, -1
With oRng.Find
.ClearFormatting
Do While .Execute(findText:="[+0-9A-z._-]{1,}\@[A-z.]{1,}", MatchWildcards:=True, Wrap:=wdFindStop, Forward:=True) = True
If oRng.InRange(oRngCurrent) Then
ActiveDocument.Range.InsertAfter oRng & "; "
Else
Exit Sub
End If
Loop
End With
End Sub

[htmldiva]

Please use the VBA code tags.

Try:
Sub BlahBlahBlah()
Dim Source As Document
Dim r As Range
Dim strAddressList As String

Set Source = ActiveDocument
Set r = Source.Range
With r.Find
Do While .Execute(findText:="[+0-9A-z._-]{1,}\@[A-z.]{1,}", MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
strAddressList = strAddressList & r.Text & "; "
Loop
End With
Source.Range.InsertAfter strAddressList
End Sub

The code uses the range (r) of the document to find the find. It then appends the string variable strAddressList with each address. You want to use a string because if you just built the end of the document with found address, then Find will find those new ones...and on and on forever. An infinite loop.

When all address are found (and the Find loop terminates), the code dumps the appended string at the end of the document.

[fumei]

You may want to use the suggestion Greg added to my code to get rid of that last dangling ;

[htmldiva]

I noticed that the code in my macro didn't grab all email addresses. Here's the code that should replace the text in quotations:

"[a-zA-Z0-9\-_.]{1,}\@[a-zA-Z0-9\-_.]{1,}"