Extract email address and copy into .To field

Hello,

I currently have a workbook that I track various projects with and periodically I will need to get updates for them. I modified the following code that I found in this forum, which works pretty well.

Sub Mail_Selection_WithSignature()

Dim Rng As Range
Dim NewMsg As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim cbc As Office.CommandBarPopup
Dim cbControls As Office.CommandBarControls
Dim cbButton As Office.CommandBarButton

Set Rng = Nothing
    On Error Resume Next
    Set Rng = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

Set NewMsg = CreateItem(olMailItem)

NewMsg.Display

Set objInsp = ActiveInspector
If Not objInsp Is Nothing Then
  Set cbc = objInsp.CommandBars.FindControl(, 31145)
End If

If Not cbc Is Nothing Then
 Set cbControls = cbc.Controls
End If

For Each cbButton In cbControls
   If cbButton.Caption = "HP" Then
       cbButton.Execute
       Exit For
    End If
Next

With NewMsg
  .To = ""
  .CC = "test1@tst.com;test2@tst.com;test3@tst.com"
  .Subject = "Request for project updates."
  .HTMLBody = "<p>Hello,</p>" & _
  "<p>Please provide updates for the following projects.</p>" & _
   RangetoHTML(Rng) & _
    .HTMLBody
End With

ExitProc:
Set cbControls = Nothing
Set cbc = Nothing
Set objInsp = Nothing
Set NewMsg = Nothing
End Sub

What I haven't been able to figure out is how to extract the email address from the selected rows, which is in column J, and add it to the .To field in the email. Additionally, if I select multiple rows I would like to test if it's a duplicate address so that only 1 gets copied to the email.

In the attached workbook you'll note that there are just names in column J. This is all I need as the exchange server will resolve the address.

Please let me know if you require any additional information. Thanks.

Regards,
Chris

I found the following from Ron de Bruin's site.

Send to all E-mail addresses in a range and check if the mail address is correct.
Add the code below to the macro and change the To line to this: .To = strto

    Dim cell As Range
    Dim strto As String
    For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A1:A10")
        If cell.Value Like "?*@?*.?*" Then
            strto = strto & cell.Value & ";"
        End If
    Next cell
    If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)

What do I need to change so that only the value of the selected row, cell J, is used?

Chris

I'm very surprised that I haven't received a response from anyone. Could one of the forum moderators help me to understand what I might be doing wrong?

I did note that I neglected to mention the version that I'm running.

Excel 2003

Outlook 2003

I really do need assistance with this. Thanks.

Chris

I made some headway. The code in red are the changes that I made.

Sub Mail_Selection_WithSignature()

Dim Rng As Range
Dim NewMsg As Outlook.MailItem
Dim objInsp As Outlook.Inspector
Dim cbc As Office.CommandBarPopup
Dim cbControls As Office.CommandBarControls
Dim cbButton As Office.CommandBarButton
Dim Sendto As String

Set Rng = Nothing
    On Error Resume Next
    Set Rng = Selection.SpecialCells(xlCellTypeVisible)
    Sendto = Cells(ActiveCell.Row, "J").Value
    On Error GoTo 0
    
    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

Set NewMsg = CreateItem(olMailItem)

NewMsg.Display

Set objInsp = ActiveInspector
If Not objInsp Is Nothing Then
  Set cbc = objInsp.CommandBars.FindControl(, 31145)
End If

If Not cbc Is Nothing Then
 Set cbControls = cbc.Controls
End If

For Each cbButton In cbControls
   If cbButton.Caption = "HP" Then
       cbButton.Execute
       Exit For
    End If
Next

With NewMsg
  .To = Sendto
  .CC = "test1@tst.com;test2@tst.com;test3@tst.com"
  .Subject = "Request for project updates."
  .HTMLBody = "<p>Hello,</p>" & _
  "<p>Please provide updates for the following projects.</p>" & _
   RangetoHTML(Rng) & _
    .HTMLBody
End With

ExitProc:
Set cbControls = Nothing
Set cbc = Nothing
Set objInsp = Nothing
Set NewMsg = Nothing
End Sub

This adds the name of the selected row to the .To field of the email.

I still need to figure out how to deal with multiple rows. I would like to test column J if it's a duplicate name. If it's duplicate than only add the first name and create 1 email. If the 2nd name is different than create another email and include the selected row that's associated with that name, etc.

Additionally, I would like the header row, A8 to L8 to always be added to the email. This way I only need to select the rows of projects that I need updates for. Alternately, I don't mind selecting this row I would just want to test the cell content in column J for the word "LPM". If it finds it then the code should skip to the next cell in column J.

I've attached the revised worksheet.

Any ideas anyone?

Chris

Can anyone assist with this? I've never had no responses before so I'm a bit confused why no one has replied. Any insight would be appreciated.

Regards,
Chris