microsoft.public.word.vba.general

Much easier just to walk the hyperlinks ...

Dim HLink As Hyperlink
Dim Source As Document
Dim Target As Document
Dim E_Mail() As String

Set Source = ActiveDocument
Set Target = Documents.Add

For Each HLink In Source.Hyperlinks
E_Mail = Split(HLink.Address, ":", 2)
If E_Mail(0) = "mailto" Then
Target.Content.InsertAfter E_Mail(1)
Target.Range.InsertParagraphAfter
End If
Next

You can tidy it up to get exactly what you want

--
Enjoy,
Tony

"Graham Mayor" wrote in message
news:O$amg%23BgIHA.1212@TK2MSFTNGP05.phx.gbl...
> Try using Word to determine what is an e-mail address by using autoformat
> eg
>
> Sub CopyEMailAddressesToOtherDoc()
> Dim Source As Document
> Dim Target As Document
> Dim myRange As Range
> Dim sView As String
>
> Set Source = ActiveDocument
> sView = ActiveWindow.View.ShowFieldCodes
> Set Target = Documents.Add
> Application.ScreenUpdating = False
> Source.Activate
> Options.AutoFormatReplaceHyperlinks = True
> With Selection
> .Range.AutoFormat
> ActiveWindow.View.ShowFieldCodes = True
> .HomeKey unit:=wdStory
> With .Find
> .ClearFormatting
> .Replacement.ClearFormatting
> Do While .Execute(findText:="^d HYPERLINK ""Mailto", _
> MatchWildcards:=False, Wrap:=wdFindStop, _
> Forward:=True) = True
> Set myRange = Selection.Range
> Target.Range.InsertAfter myRange & vbCr
> Loop
> End With
> .HomeKey unit:=wdStory
> End With
> ActiveWindow.View.ShowFieldCodes = sView
> Source.Close Savechanges:=wdDoNotSaveChanges
> Target.Activate
> With Selection.Find
> .ClearFormatting
> .Replacement.ClearFormatting
> .Text = "^019 HYPERLINK ""mailto:(*)"" ^21"
> .Replacement.Text = "\1"
> .MatchWildcards = True
> .Execute Replace:=wdReplaceAll
> End With
> Selection.Sort FieldNumber:="Paragraphs", _
> SortFieldType:=wdSortFieldAlphanumeric, _
> SortOrder:=wdSortOrderAscending
> End Sub
>
> --
> <>>< ><<> ><<> <>>< ><<> <>>< <>><<>
> Graham Mayor - Word MVP
>
> My web site www.gmayor.com
> Word MVP web site http://word.mvps.org
> <>>< ><<> ><<> <>>< ><<> <>>< <>><<>
>
>
> Ray C wrote:
>> I'm using Word VBA to retrieve email addresses inside a Word
>> document. The problem I encounter is that sometimes there are tabs,
>> carriage returns, ie special characters before and after the email
>> address that also get pulled and appear as small squares in the text
>> that I retrieve. My logic is like this:
>>
>> 1) Find occurence of @ sign.
>> 2) Pull the sentence that contains the @ sign and use the Split
>> function to create an array of words in the sentence (one word will
>> eventually contain the full email address).
>>
>> Problem: When I look at the array item that contains the email
>> address, there are also tabs, carriage returns, etc that get
>> interpreted as small squares in my output.
>>
>> Here is my code:
>>
>> For Each rngStory In objDocument.StoryRanges
>> With rngStory.Find
>> .ClearFormatting
>> .Text = "@"
>> .Wrap = wdFindStop
>> .Forward = True
>> End With
>> Do Until rngStory.Find.Execute = False
>> With rngStory.Duplicate
>> .Expand Unit:=wdSentence
>> myArray = Split(.Text, " ", -1, vbTextCompare)
>> For i = 0 To UBound(myArray)
>> If InStr(1, myArray(i), "@", vbTextCompare) <>
>> 0 Then If numEmailsFound < 3 Then
>> '/// Copy email address to excel.
>> End If
>> End If
>> Next i
>> End With
>> Loop
>> Next rngStory
>
>