Dynamic email macro based on cell location

[nuckfuts]

Hi All,

I wanted to create a =HYPERLINK email generator based on cell values in the active row but #VALUE reared its ugly head. It would work great if I didn't run into character limits, so now I must resort to macros.

The Recipient name, To: CC: Subject: Body: etc., will be filled in columns A, B, C, D, for example.
Each row will be for a different recipient, thus the above message components will vary row to row.
In the last columns (lets say column E), I'd like a hyperlink (or similar) to press and generate the email for that recipient.

Some values in the columns B, C, D containing the message components use CONCAT like if there are multiple "To" email addresses

Any help or ideas would be appreciated, essentially I'd like to run one macro that changes the above variables based on row value.

 

[ManiacB]

Try the following, but instead of a link, type "send" into column H to execute the macro to send the email. Create the information with the headers aligned as shown below.

Place the following code in the sheet1 code module:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
        If Target.Value = "send" Then
        i = Target.Row
        MsgBox "Send Mail on row " & i
        Call SendEmail(i)
        End If
    End If
End Sub


Sub SendEmail(i As Long)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lr As Integer
    Dim Path, strBody As String
    'Dim i As Long
    
    Application.ScreenUpdating = False

        On Error GoTo erHandle
            If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
                Sheet1.Cells(i, "G").Value = "Bad Email"
                GoTo skip
            End If
            If IsEmpty(Cells(i, "G").Value) Then
                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = Sheet1.Cells(i, "A").Value
                    .CC = Sheet1.Cells(i, "B").Value
                    .BCC = Sheet1.Cells(i, "F").Value
                    .Subject = Sheet1.Cells(i, "C").Value
                    .HTMLBody = Sheet1.Cells(i, "D").Value
                    If Not IsEmpty(Sheet1.Cells(i, "E")) Then
                        .Attachments.Add Sheet1.Cells(i, "E").Value
                    End If
                    .Display    'DELETE THIS LINE IF USING SEND
                    '.send
                End With
            Sheet1.Cells(i, "G").Value = Date
            Set OutMail = Nothing
            Set OutApp = Nothing
            End If
skip:
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub
Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function

 

[nuckfuts]

This

Try the following, but instead of a link, type "send" into column H to execute the macro to send the email. Create the information with the headers aligned as shown below.
View attachment 25516

Place the following code in the sheet1 code module:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
        If Target.Value = "send" Then
        i = Target.Row
        MsgBox "Send Mail on row " & i
        Call SendEmail(i)
        End If
    End If
End Sub


Sub SendEmail(i As Long)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lr As Integer
    Dim Path, strBody As String
    'Dim i As Long
   
    Application.ScreenUpdating = False

        On Error GoTo erHandle
            If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
                Sheet1.Cells(i, "G").Value = "Bad Email"
                GoTo skip
            End If
            If IsEmpty(Cells(i, "G").Value) Then
                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = Sheet1.Cells(i, "A").Value
                    .CC = Sheet1.Cells(i, "B").Value
                    .BCC = Sheet1.Cells(i, "F").Value
                    .Subject = Sheet1.Cells(i, "C").Value
                    .HTMLBody = Sheet1.Cells(i, "D").Value
                    If Not IsEmpty(Sheet1.Cells(i, "E")) Then
                        .Attachments.Add Sheet1.Cells(i, "E").Value
                    End If
                    .Display    'DELETE THIS LINE IF USING SEND
                    '.send
                End With
            Sheet1.Cells(i, "G").Value = Date
            Set OutMail = Nothing
            Set OutApp = Nothing
            End If
skip:
   
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
   
End Sub
Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function

worked great! Did some tweaking but was exactly what I needed. Thanks!