Generating an email based on cell content (text)

[Blanchetdb]

I am experiencing issues in regards to the coding required to do the following:

I need to generate an email to a specific email address when an individual selects (from a drop don menu) the option "yes or "oui" in cell F10. Also I require the same process to take place in various other cells in the worksheet but the email address will be different in each case as well as the drop down menu in each cell

for example:

cell F10 - drop down menu (yes, no - oui, non) / client selects "yes" or "oui" email goes to xxxxxxxxxxx@Canada.ca, if "no" or "non" is selected, no email is generated
cell J14 - drop down menu (Granted, pending - acquise, en attente) / client selects "granted" or "acquise" email goes to yyyyyyyyyy@Canada.ca, if blank or "pending" or "en attente" is selected, no email is generated.
cell E49 - drop down menu (yes, no - oui, non) / (same as F10 but different email address) email goes to zzzzzzzzzzzzzzz@Canada.ca

assistance with this would be greatly appreciated

thank you

Dan

 

[bugmonsta]

Ok, heres my quick and dirty idea, using outlook....

This is my test code so I am using F10 and F11 as the 2 cells, F10 replicates your original data idea and F11 is just me randomly creating a second one to see if it works.

You can add as many as you like, there may be a better way of doing this section (joining the ifs together??) but it works and allows you to add multiple cells to look at so have a test

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("f10")) Is Nothing Then

If Target = "yes" Or Target = "oui" Then
emsg = "msg1"
   Call Mail(emsg)
Else
    End If
End If


If Not Intersect(Target, Range("f11")) Is Nothing Then
If Target = "boo" Or Target = "boom" Then
emsg = "msg2"
   Call Mail(emsg)
Else
    End If
End If

End Sub

In a module enter the code below, which is built from Ron De Bruin code as he is the grand wizard of all things email!!

I have highlighted in green the lines I have had to temp remove from this test as when then code runs, it was looking at these lines and erroring, so you can either include them in your testing (using relevant paths) or remove them completely.
I have created the red lines to help you see the split in the coding!

I am off into an all day meeting but please message me if you have queries and I should reply at some point this week!! Sorry for any mistakes, I am in a rush today but just wanted to post this to see if it helps....

Sub Mail(emsg)
[COLOR="#FF000"]'///start of settings[/COLOR]
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody, SigString, Signature, subline, bodytxt, pthbody, carbon As String
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    carbon = ""
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
[COLOR="#FF000"]'///end of settings[/COLOR]




[COLOR="#FF000"]'///start varaible message types[/COLOR]
If emsg = "msg1" Then
strbody = "****** style=font-size:10pt;font-family:Arial>" & "Dear Bob," & "<br> <br>" _
& "information for you:  <br> "

   subline = "oui F10 test"
   pthbdy = ""
  [COLOR="#008000"] 'pthbdy = "\\pathForBodyEmail\Bodytype1.htm" ' not used in this test, put in a blank line above
    'bodytxt = fso.OpenTextFile(pthbdy).ReadAll ' contents of above file ' this is not used in this test as its a fake file path in the line above
[/COLOR]         bodytxt = "this is mybody"
       sensr = 1
    On Error Resume Next
    readr = True
    deliverr = False
     ename = "xxx.candada.ca"
     carbon = "enteranotheraddressifyouwant"
End If



If emsg = "msg2" Then
strbody = "****** style=font-size:10pt;font-family:Arial>" & "Dear Sarah," & "<br> <br>" _
& "information for you:  <br> "

   subline = "F11 message 2 subline"
  [COLOR="#008000"] 'pthbdy = "\\pathForBodyEmail\Bodytype2.htm"
    'bodytxt = fso.OpenTextFile(pthbdy).ReadAll ' contents of above file
[/COLOR]    bodytxt = "this is mybody"
       sensr = 1
    On Error Resume Next
    readr = True
    deliverr = False
       ename = "ZZZ.candada.ca"
        carbon = ""
End If
[COLOR="#FF000"]'///end of varaible message types

'///The actual mail generation[/COLOR]

    With OutMail

        .To = ename
        .cc = carbon
        .BCC = ""
        .Subject = subline
        .HTMLBody = strbody & bodytxt & "<br>" & .HTMLBody
        .Importance = 2
        .ReadReceiptRequested = readr
        .OriginatorDeliveryReportRequested = deliverr
        .Sensitivity = sensr
[COLOR="#008000"]        '.SentOnBehalfOfName = """enter a mailbox if you want to use this"[/COLOR]
        If emsg = "msg1" Then
[COLOR="#008000"]        '.attachments.Add "\\pathtoyourattachment.pdf"
        '.attachments.Add "\\pathtoanotherattachment.dox"[/COLOR]
         End If
          If emsg = "msg2" Then
[COLOR="#008000"]          '.attachments.Add "\\addadifferentattachment.pdf"[/COLOR]
          End If
                
        .Display    'or use .send
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[Blanchetdb]

the help is much appreciated.....

this is what I have and unfortunately it doesn't seem to work, no sure what I am missing (It will not send out an email):


Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F10")) Is Nothing Then
emsg = "msg1"
If Target = "yes" Or Target = "oui" Then
Call Mail(emsg)
Else
End If
End If
If Not Intersect(Target, Range("J14")) Is Nothing Then
emsg = "msg2"
If Target = "Granted" Or Target = "Acquise" Then
Call Mail(emsg)
Else
End If
End If
End Sub
Sub Mail(emsg)
Dim OutApp As Object
Dim OutMail As Object
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
If emsg = "msg1" Then
MailBody = "Hi Christine" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With OutMail
.To = "Daniel.Blanchet@canada.ca"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = MailBody
.Display 'or use .Send
End If

If emsg = "msg2" Then
MailBody = "Hi Security" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With OutMail
.To = "Daniel.Blanchet@canada.ca"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = MailBody
.Display 'or use .Send
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

 

[bugmonsta]

Hi again,
Just tested your code and it works for me, so I apologise if you have already done this, but I need to check what steps you have followed - this first section, did you right click your worksheet (sheet1, sheet2 etc) and click on view code, this is where you would paste it in:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F10")) Is Nothing Then
emsg = "msg1"
If Target = "yes" Or Target = "oui" Then
Call Mail(emsg)
Else
End If
End If
If Not Intersect(Target, Range("J14")) Is Nothing Then
emsg = "msg2"
If Target = "Granted" Or Target = "Acquise" Then
Call Mail(emsg)
Else
End If
End If
End Sub

Then whilst you have the window open that you pasted the above code into, click Insert > Module (would create Module1, Module2 etc) and paste the code below into that window?
Please note that whilst testing and indeed pasting your code in, I have removed the email address you had in the code.

Sub Mail(emsg)
Dim OutApp As Object
Dim OutMail As Object
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


If emsg = "msg1" Then
MailBody = "Hi Christine" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With OutMail
.To = "me@me.com"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = MailBody
.Display 'or use .Send
End With
End If

If emsg = "msg2" Then
MailBody = "Hi Security" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With OutMail
.To = "me@me.com"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = MailBody
.Display 'or use .Send

End With
End If



On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Also, are you using outlook, and is it running on this machine?

 

[Blanchetdb]

Hi,

I have it exactly as you have it displayed and the same locations.....I am using Outlook and it is functional on my machine. Not sure why it isn't working

 

[bugmonsta]

Hi again, that is strange as it works for me, I am running Excel 2016 and Outlook 2016 (16.0.9126.2259)

This code IS case sensitive as well so YES will not work in F10 as the code is set for lowercase... just in case that what is causing the problem.

Lets add some message boxes to see where the code is getting to, and test around F10 - highlighted the new lines in red - all plain message boxes to show you where the code is triggering:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F10")) Is Nothing Then
emsg = "msg1"
If Target = "yes" Or Target = "oui" Then
[COLOR="#FF0000"]msgbox "OUI OR YES WAS FOUND"[/COLOR]
Call Mail(emsg)
Else
End If
End If
If Not Intersect(Target, Range("J14")) Is Nothing Then
emsg = "msg2"
If Target = "Granted" Or Target = "Acquise" Then
msgbox "GRANTED OR ACQ WAS FOUND"
Call Mail(emsg)
Else
End If
End If
End Sub

Sub Mail(emsg)
Dim OutApp As Object
Dim OutMail As Object
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
[COLOR="#FF0000"]MSGBOX "MAIL CODE HAS KICKED IN"[/COLOR]

If emsg = "msg1" Then
[COLOR="#FF0000"]MSGBOX "MSG1 WAS PASSED HERE"[/COLOR]
MailBody = "Hi Christine" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With OutMail
[COLOR="#FF0000"]msgbox "OUTMAIL IS BEING CALLED"[/COLOR]
.To = "me@me.com"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = MailBody
.Display 'or use .Send
End With
End If

If emsg = "msg2" Then
MailBody = "Hi Security" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With OutMail
.To = "me@me.com"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = MailBody
.Display 'or use .Send

End With
End If
[COLOR="#FF0000"]MSGBOX "END OF EMAIL CODE"[/COLOR]

 

[Blanchetdb]

Hi,

Finally got it to work ..... much appreciated

 

[bugmonsta]

Cool - thanks for letting me know