VBA Recording Challenges

[bokenrosie]

How do I record what F8 extend is doing?

I need to find and copy email addresses.

Thanks

[gmayor]

This is not a job for the macro recorder. What do you want to do with the found address(es)? The following macro will display them in a message box. The macro uses the Find function to find the addresses.


Option Explicit
Public Sub GetEmailAddresses()
Dim oDoc As Document
Dim oStory As Range
Set oDoc = ActiveDocument
For Each oStory In oDoc.StoryRanges
With oStory.Find
Do While .Execute(FindText:="[a-zA-Z0-9\-_.]{1,}\@[a-zA-Z0-9\-_.]{1,}", _
MatchWildcards:=True)
'Do something with the found address e.g.
MsgBox oStory.Text
'Then move on
oStory.Collapse 0
Loop
End With
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
With oStory.Find
Do While .Execute(FindText:="[a-zA-Z0-9\-_.]{1,}\@[a-zA-Z0-9\-_.]{1,}", _
MatchWildcards:=True)
'Do something with the found address e.g.
MsgBox oStory.Text
'Then move on
oStory.Collapse 0
Loop
End With
Wend
End If
Next oStory
lbl_Exit:
Set oStory = Nothing
Set oDoc = Nothing
Exit Sub
End Sub

[gmaxey]

Graham,

Sounds like they are trying to find and select multiple email addresses and copy them to the clipboard:


Option Explicit
Dim oSpike
Public Sub GetEmailAddresses()
Dim oDoc As Document
Dim oStory As Range
Set oSpike = New DataObject
Set oDoc = ActiveDocument
oSpike.SetText ""
For Each oStory In oDoc.StoryRanges
With oStory.Find
Do While .Execute(FindText:="[a-zA-Z0-9\-_.]{1,}\@[a-zA-Z0-9\-_.]{1,}", _
MatchWildcards:=True)
'Do something with the found address e.g.
CopyTextToClipboard oStory.Text
'Then move on
oStory.Collapse 0
Loop
End With
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
With oStory.Find
Do While .Execute(FindText:="[a-zA-Z0-9\-_.]{1,}\@[a-zA-Z0-9\-_.]{1,}", _
MatchWildcards:=True)
'Do something with the found address e.g.
CopyTextToClipboard oStory.Text
'Then move on
oStory.Collapse 0
Loop
End With
Wend
End If
Next oStory
Selection.Range.Paste
lbl_Exit:
Set oStory = Nothing
Set oDoc = Nothing
Exit Sub
End Sub
Sub CopyTextToClipboard(strText)
Dim strContent As String
strContent = oSpike.GetText
oSpike.SetText strContent & vbCr & strText
'Place DataObject's text into the Clipboard
oSpike.PutInClipboard
End Sub

[gmayor]

Greg
Have you been polishing your crystal ball? ;)

[gmaxey]

Graham,

Not much else of interest to polish. Their .. and copy ... was a subtle nudge though :think: