Word 2010 Table - loop through table cells and combine email addresses into range ";

[pk247]

Hi Everyone,

I'm really stuck with a process I'm trying to automate and hopefully you could help me please?

I've made a tool that let's me decide whether to send the active word doc as an attachment in Word or PDF format.

What I would like to automate now is extracting the email addresses from a table within the active document to store as string and be used in the ".To = Email_List" of the code. The recipients listed in that table should be the only people to ever receive the document so it'll reduce the risk of me ever emailing the doc in error (it can happen to anyone...)!

There are merged cells in the table that is found so I'm using a regular expression pattern just to pull all email address format matches. It's working great (with the msgbox returing all email addresses) but I need to combine these emails addresses together so I can pass them into the .To = field as a string with a semicolon and space separator & "; ". I can find multiple examples of this in Excel but I can't make it work.

Here's my code so far:

Sub Table_PullEmailList()
Dim otbl As Table
Dim objRegExp As Object
Dim objMatch As Object
Dim objMatches As Object
Dim objWordDoc As Object

Set objRegExp = CreateObject("VBScript.RegExp")

objRegExp.IgnoreCase = True ' Ignore case.
objRegExp.MultiLine = False ' Cancel multiline mode.
objRegExp.Global = True ' Global match.
objRegExp.Pattern = "\w+([-+.]\w+)*@\w+([-.]\w+)*\.*"
Application.DisplayAlerts = wdAlertsNone

Selection.Find.ClearFormatting
With Selection.Find
.Text = "Enter the Email address of the recipients of this document. This may include the email address of recipients who will not sign off on this document."
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
With Selection.Tables(1)
Set otbl = Selection.Tables(1)
For Each ocell In otbl.Range.Cells
Set objMatches = objRegExp.Execute(ocell.Range.Text)
' /* Step through Match object in the MatchCollection object. */
For Each objMatch In objMatches
MsgBox objMatch
'STUCK HERE >>>>I need to find a way to combine each objMatch for my .To String
Next
Next
End With

End If
Selection.Collapse Direction:=wdCollapseEnd

Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True

'Release memory
If Not (objWordDoc Is Nothing) Then Set objWordDoc = Nothing
If Not (objRegExp Is Nothing) Then Set objRegExp = Nothing
If Not (objMatch Is Nothing) Then Set objMatch = Nothing
If Not (objMatches Is Nothing) Then Set objMatches = Nothing

End Sub

Hopefully someone can point me in the right direction please.

Thanks!!

Paul, IRELAND

[gmaxey]

If Selection.Information(wdWithInTable) Then
With Selection.Tables(1)
Set otbl = Selection.Tables(1)
For Each oCell In otbl.Range.Cells
Set objMatches = objRegExp.Execute(oCell.Range.Text)
' /* Step through Match object in the MatchCollection object. */
For Each objMatch In objMatches
strTo = strTo & objMatch & ";"
Next objMatch
Next
End With
End If

[pk247]

Thank you Greg!! Worked an absolute charm. I really appreciate your help not only with this and my prevous posts but I'm learning so much from ALL the other posts you respond to. You are very kind!

Cheers :beerchug:

Paul, IRELAND

[gmaxey]

Paul,

Before using strTo, be sure to strip off the dangling ";"

If strTo <> vbNullString Then strTo = Left(strTo, Len(strTo) - 1)
MsgBox strTo

[pk247]

Thanks for the pointer Greg!