VBA Open Outlook template based on cell value then email then repeat next row

[rplohocky]

Hello,
I'm looking for code that will open a specific Outlook template based on what is in cell H1, allow to add 3 different cell values to the subject line, then email, automatically, and then move to the next row and do the same thing until there's no more populated rows.

I have 3 different templates saved in a folder on my desktop. The file extension is .msg.

It would look like this...
if H1 says "Assigned" then open template "ASSIGNED" and then grab the data from cell A1 and place in the subject line and then from B1 and C1.

The subject line would look like this...

Driver Add Request Fleet (FROM B1) Workflow# (FROM A1) / (FROM C1)

Any help would be great!

 

[Worf]

Hello

' Excel module
Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    p = "c:\pub\" & Cells(i, "h") & ".msg"              ' template path
    Set msg = objOL.CreateItemFromTemplate(p)
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h")
    msg.Subject = "Driver Add Request Fleet " & [b1] & " Workflow#" & [a1] & " / " & [c1]
    msg.Display
'    msg.Send
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

 

[rplohocky]

Hello

' Excel module
Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    p = "c:\pub\" & Cells(i, "h") & ".msg"              ' template path
    Set msg = objOL.CreateItemFromTemplate(p)
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h")
    msg.Subject = "Driver Add Request Fleet " & [b1] & " Workflow#" & [a1] & " / " & [c1]
    msg.Display
'    msg.Send
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

Hello Worf, cool screen name!
Thanks for the code. I think this is close but not quite complete.

This macro can not be set to look in one specific cell, it would need to look in the entire "H" column to see what each cell says then grab the appropriate template. For example....

H1 says "Assign Driver Only", the macro would be smart enough to grab the template (template name "AD Only") that applies to that cell title.

H2 says "Locate Driver Only", the macro would grab a different template named "LD ONLY".

H3 says "Discontinue Driver", the macro would grab another different template named "Dis Driver".

H4 says "Assign Driver Only" (just like H1), the macro would would grab the template named "AD Only".

This macro needs to look at what is listed in each cell in column H and grab a template based on what the cell says and continue this until there are no more populated cells in column H.

Also keep in mind that the subject line would need to grab the data from the same row as the cell that it is applying the template from (i.e. H3 is grabbing template "Dis Driver" because H3 says "Discontinue Driver").

An example would be...

Row 3 cell H3 says Discontinue Driver", the macro grabs template "Dis Driver" and then grabs the cell B3 to insert the Fleet number in the subject line, then grabs the cell A3 to get the workflow# and inserts that into the subject line, then grabs the cell C3 to get the Unit# and inserts it into the subject line. Fleet (FROM B1) Workflow# (FROM A1) / (FROM C1)

I know this is confusing but I'm trying to describe as best as I can. Basically the macro needs to look in the H column and open the template based on what is in the cell then grab the info attached to that row.

 

[Worf]

New version:

Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    Select Case UCase(Left(Cells(i, "h"), 1))
        Case "A": p = "AD Only"
        Case "L": p = "LD Only"
        Case "D": p = "Dis Driver"
    End Select
    Set msg = objOL.CreateItemFromTemplate("c:\pub\" & p & ".msg")
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h")
    msg.Subject = "Driver Add Request Fleet " & Cells(i, 2) & " Workflow#" & _
    Cells(i, 1) & " / " & Cells(i, 3)
    msg.Display
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

 

[rplohocky]

New version:

Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    Select Case UCase(Left(Cells(i, "h"), 1))
        Case "A": p = "AD Only"
        Case "L": p = "LD Only"
        Case "D": p = "Dis Driver"
    End Select
    Set msg = objOL.CreateItemFromTemplate("c:\pub\" & p & ".msg")
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h")
    msg.Subject = "Driver Add Request Fleet " & Cells(i, 2) & " Workflow#" & _
    Cells(i, 1) & " / " & Cells(i, 3)
    msg.Display
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

Worf,
This code work exactly like I wanted it to but when ever I run the code the warning message you have in your code pops up just before the code opens the template. This happens whether there is one template to open or 10. Can you tell me why this would happen? It would be perfect if the code just ran without the pop ups because I have to click "ok" for every email template.

 

[Worf]

Try the version below. If errors still happen, remove the “on error resume next” statement and tell me the resulting error number and what is the offending line of code.

Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    Select Case UCase(Left(Cells(i, "h"), 1))
        Case "A": p = "AD Only"
        Case "L": p = "LD Only"
        Case "D": p = "Dis Driver"
    End Select
    Set msg = objOL.CreateItemFromTemplate("c:\pub\" & p & ".msg")
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h") & "/Error #" & Err.Number
    msg.Subject = "Driver Add Request Fleet " & Cells(i, 2) & " Workflow#" & _
    Cells(i, 1) & " / " & Cells(i, 3)
    msg.Display
    Err.Clear
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

 

[rplohocky]

Try the version below. If errors still happen, remove the “on error resume next” statement and tell me the resulting error number and what is the offending line of code.

Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    Select Case UCase(Left(Cells(i, "h"), 1))
        Case "A": p = "AD Only"
        Case "L": p = "LD Only"
        Case "D": p = "Dis Driver"
    End Select
    Set msg = objOL.CreateItemFromTemplate("c:\pub\" & p & ".msg")
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h") & "/Error #" & Err.Number
    msg.Subject = "Driver Add Request Fleet " & Cells(i, 2) & " Workflow#" & _
    Cells(i, 1) & " / " & Cells(i, 3)
    msg.Display
    Err.Clear
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

Worf,
This new code worked great, no errors!

Now for the next part of this code. Can you add the ability to attach an attachment to the template based on what is in the cell next to the cell that has the "case" name?

An example would be if cell H2 has "A" in it and its going to open template "AD Only" then look in cell "K" and go to folder "C:\Users\RPlohocky\Desktop\Macro Projects" and grab the right attachment. Cell "K" may be named "555666444" (or something) and folder "Macro Projects" holds numerous files. The code would need to grab the correct file based on the name in cell "K".

This would finish this macro. I really appreciate your help!! Thank you.

 

[Worf]

Like this:

Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%, ap$
ap = "C:\Users\Public\CyberLink\"                               ' attachments path
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    Select Case UCase(Left(Cells(i, "h"), 1))
        Case "A": p = "AD Only"
        Case "L": p = "LD Only"
        Case "D": p = "Dis Driver"
    End Select
    Set msg = objOL.CreateItemFromTemplate("c:\users\public\documents\" & p & ".msg")
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h") & "/Error #" & Err.Number
    msg.Subject = "Driver Add Request Fleet " & Cells(i, 2) & " Workflow#" & _
    Cells(i, 1) & " / " & Cells(i, 3)
    msg.Attachments.Add ap & Cells(i, "k")      ' column K uses the format filename.ext
    msg.Display
    Err.Clear
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

 

[rplohocky]

Like this:

Sub OL()
Dim objOL As Outlook.Application, msg As MailItem, p$, i%, ap$
ap = "C:\Users\Public\CyberLink\"                               ' attachments path
Set objOL = CreateObject("Outlook.Application")
On Error Resume Next
For i = 1 To Range("h" & Rows.Count).End(xlUp).Row
    Select Case UCase(Left(Cells(i, "h"), 1))
        Case "A": p = "AD Only"
        Case "L": p = "LD Only"
        Case "D": p = "Dis Driver"
    End Select
    Set msg = objOL.CreateItemFromTemplate("c:\users\public\documents\" & p & ".msg")
    If Err.Number > 0 Then MsgBox "No such template", vbCritical, Cells(i, "h") & "/Error #" & Err.Number
    msg.Subject = "Driver Add Request Fleet " & Cells(i, 2) & " Workflow#" & _
    Cells(i, 1) & " / " & Cells(i, 3)
    msg.Attachments.Add ap & Cells(i, "k")      ' column K uses the format filename.ext
    msg.Display
    Err.Clear
Next
Set msg = Nothing
Set objOL = Nothing
End Sub

Worf,
Your new addition to the code works great! Thank you. Looking at this a little deeper, can you provide a way to attach files from a sharepoint site? I tried using what you sent but it doesn't work for sharepoint, I would think that it would be slightly different. Thanks!

 

[rplohocky]

Worf,
Your new addition to the code works great! Thank you. Looking at this a little deeper, can you provide a way to attach files from a sharepoint site? I tried using what you sent but it doesn't work for sharepoint, I would think that it would be slightly different. Thanks!

Worf,
Sorry after further testing the attachment addition is not working. I run the macro and for a second it looks like its going to do something but nothing happens. Before I inserted the attachment code or if i turn off the new code your old code works as it should. It opens the correct template based on cell value. When I try to add the attachment code it does nothing. Any idea why?