I have a small piece of vba-code running perfect in office 2010. When running in office 365, it gives an "index out of range"-error, but not when I step into the code with the Outmail-variabele open in the locals-window. The aim of the code is to attach one or more pdf's to a template mail.
The error is when Display in yellow.
Sub Mailing()
Dim OutApp As Object
Dim OutMail As Object
Dim onderworpenNL As String
Dim onderworpenFR As String
onderworpenNL = "some text"
onderworpenFR = "some text"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\res.sys.shared....\macromail_mail1.oft")
With OutMail
.SentOnBehalfOfName = "dd#dd.com"
.to = Range("H" & (ActiveCell.Row))
.Subject = "some text: " & Range("B" & (ActiveCell.Row)) & " - " & "account: " & Range("A" & (ActiveCell.Row))
.HTMLBody = Replace(.HTMLBody, "REPLACENAAM", Range("B" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEWHK", Range("C" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEREDENNL", Range("F" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEREDENFR", Range("F" & (ActiveCell.Row)))
If Range("G" & (ActiveCell.Row)).Value = "Yes" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENNL", onderworpenNL)
If Range("G" & (ActiveCell.Row)).Value = "No" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENNL", "")
If Range("G" & (ActiveCell.Row)).Value = "Yes" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENFR", onderworpenFR)
If Range("G" & (ActiveCell.Row)).Value = "No" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENFR", "")
On Error Resume Next
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & ".pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_1.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_2.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_3.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_4.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_5.pdf"
On Error GoTo 0
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Just change
Set OutMail = OutApp.CreateItemFromTemplate("\\res.sys.shared....\macromail_mail1.oft")
For
Set OutMail = OutApp.CreateItem(0)
and it shall work in both excels
Related
The below code embeds the photo but doesn't display because
"The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location."
I know the file path is correct.
Sub mail()
Dim Sig As String
Set myOlApp = CreateObject("Outlook.Application")
LR400 = Columns(1).Find("*", SearchDirection:=xlPrevious).Row
sPath = Environ("appdata") & "\Microsoft\Signatures\Amir Higgs.txt"
For x = 2 To LR400
If Cells(x, 2) <> "no email" Then
emails = Cells(x, 1)
'TheBody1 = "The Parallon Workforce Team" & vbCrLf & vbCrLf & vbCrLf & _
"Amir Higgs" & vbCrLf & _
"Accounts Payable Clerk" & vbCrLf & _
"Parallon Workforce Solutions" & vbCrLf & _
"1000 Sawgrass Corporate Pkwy, 6th Floor" & vbCrLf & _
"Sunrise, FL 33323" & vbCrLf & _
"P: 954-514-1656" & vbCrLf & _
"www.parallon.com"
Set myitem = myOlApp.CreateItem(olMailItem)
With myitem
.SentOnBehalfOfName = "PARA.WFAdjustments#Parallon.com"
.To = Cells(x, 2)
.Subject = Cells(x, 3)
.Body = TheBody1
'.CC = ""
.Attachments.Add emails
.Attachments.Add "C:\Users\JoeSchmo\Pictures\WF Communications.jpg", olByValue, 0
.HTMLBody = "<BODY><IMG src=""cid:WF Communications.jpg"" width=200> </BODY>"
.display
End With
End If
Next x
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Change your JPG file name to one word Example WF_Communications.jpg or WFCommunications.jpg
.Attachments.Add "C:\Users\JoeSchmo\Pictures\WF_Communications.jpg", olByValue, 0
.HTMLBody = "<BODY><IMG src=""cid:WF_Communications.jpg"" width=200> </BODY>"
I'm looking to make an automated email script using vba to read from an Excel spreadsheet; the email address and dates (that sort of thing) then place them into the correct fields to send
It would be preferable if it could also finish the line of the spreadsheet and start a new one with a new email
I can currently make an email with vba but that's about it and manually dictate the fields within the script but that's about it. Any help on how to input cell data automatically would be much appreciated.
Thanks :)
Edit 1:
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & Range("C" & Line).Value & " " & Range("B" & Line).Value & " - " & Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & Range("C" & Line).Value & " " & Range("B" & Line).Value & "'s appointment with Dr " & Range("E" & Line).Value & " on " & Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub
This seems to be the solve in case anyone has the same issue.
Thanks
The below code is more specific when defining the cells, which worked during my testing.
Option Explicit
Sub Send_email()
Dim Line As Long
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
For Line = 2 To 3
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
With OutlookMail
.To = ws.Range("A" & Line).Value
.CC = ""
.BCC = ""
.Subject = "OVERDUE DOCUMENTATION - " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & " - " & ws.Range("D" & Line).Value
.BodyFormat = olFormatHTML
.Display
.HTMLBody = "Dear " & ws.Range("F" & Line).Value & "," & "<br>" & "<br>" & "The documentation for " & ws.Range("C" & Line).Value & " " & ws.Range("B" & Line).Value & "'s appointment with Dr " & ws.Range("E" & Line).Value & " on " & ws.Range("D" & Line).Value & " is now overdue." & "<br>" & "<br>" & "Please send through the documentation immediately or the doctor may cancel this appointment due to insufficient time too view the documents prior to the appointment." & "<br>" & "<br>" & "<br>" & "Regards," & "<br>" & "<br>" & "Documents Team" & .HTMLBody
End With
Next Line
End Sub
I am using below code to send email from excel when user press the button. it works fine. i actually want to fine tune this because right now what is happening is when in Column C there is a duplicate email and in column N it is all yes separate emails are generated. what i want to do is if there is a duplicate email in column C one email should be generated with subject and body from the duplicate rows
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
"were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"This is a system generated email and doesn't require signature"
On Error Resume Next
With xOutMail
.To = Cells(Cell.Row, 3)
.CC = Cells(Cell.Row, 5)
.BCC = ""
.Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell
You can try:
Option Explicit
Public Sub Get_Unique_Count_Paste_Array()
Dim Ob As Object
Dim rng As Range
Dim LR As Long
Dim str As String
With Worksheets("Sheet1")
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set Ob = CreateObject("scripting.dictionary")
For Each rng In .Range("C8:C" & LR)
str = Trim(rng.Value)
If Len(str) > 0 Then
Ob(str) = Ob(str) + 1
If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
MsgBox str '<= Insert your code here
End If
End If
Next rng
End With
End Sub
I have created a table that will be placed in the body of an Outlook email in HTML format. I am struggling to place the values into proper columns. I have been playing around with "td" tags, but unsuccessful. All the values are now next to each other without spaces between them and therefore not in proper table format. Please help!
My code:
Public Sub HypMail4()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set Out App = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = ""
strbody = strbody & _
"<html>" & "<table>" & "<font color = ""red""><b>" & Range("A1") &
Range("B1") & Range("C1") & Range("D1") & Range("E1") & "</font></b>" & "
</th>" & _
"<tr>" & Range("A2") & Range("B2") & Range("C2") & Range("D2") & Range("E2")
& "</tr>"
strbody = strbody & _
"<tr>" & Range("A3") & Range("B3") & Range("C3") & Range("D3") & Range("E3")
& "</tr>"
strbody = strbody & _
"<tr>" & Range("A4") & Range("B4") & Range("C4") & Range("D4") & Range("E4")
& "</tr>" & "</table>" & "</html>"
On Error Resume Next
With OutMail
.To = "zzz#example.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I managed to answer my question myself by indeed including td tags. The main problem, however, was that I defined strbody too many times which messed up the table format (hence td tags weren't working) - please see code below:
Public Sub Test()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<html>" & "<table>" & "<tr>" & "<td>" & Range("A1") & "</td>" & "<td>" & Range("B1") & "</td>" & "<td>" & Range("C1") & "</td>" & "</tr>" & _
"<tr>" & "<td>" & Range("A2") & "</td>" & "<td>" & Range("B2") & "</td>" & "<td>" & Range("C2") & "</td>" & "</tr>" & _
"<tr>" & "<td>" & Range("A3") & "</td>" & "<td>" & Range("B3") & "</td>" & "<td>" & Range("C3") & "</td>" & "</tr>" & _
"<tr>" & "<td>" & Range("A4") & "</td>" & "<td>" & Range("B4") & "</td>" & "<td>" & Range("C4") & "</td>" & "</tr>" & "</table>" & "</html>"
With OutMail
.To = "zzz.com#zzz.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I have to create a VBA to send automatic e-mails (the body of the e-mail links the recipient to a specific project that he is responsible for). The problem that I encountered is the fact that a certain recipient (i.e. placed in "TO") can be responsible for more tasks. The VBA that I am using sends emails to each task (even if the person is responsible for more). What can I do to count through recipients, if it's greater than 1 to send the e-mail which includes all of the tasks. I really need your help.
<PRE>Sub SendEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim lastRow As Long
Dim Ebody As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastRow
Ebody = "<FONT SIZE = 4 name = Arial>" & "Dear " & Cells(i, "A").Value
& "<br>" _
& "<br>" _
& "Please note that the below mentioned projectd are in scope for reporting." & "<br>" _
& "<br>" _
& Cells(i, "C").Value & " - " & Cells(i, "E").Value & "<br>" _
& "xxxxx will investigate and action your notification according to priority and to ensure public safety." & "<br>" _
& "For further information, please phone xxxxx on 6111 and quote reference number:" & "<br>" _
& "Your original report can be seen below:" & "</Font>" & "<br>" _
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Cells(i, "B").Value
.Cc = Cells(i, "D").Value
.Subject = "Your Registration Code"
.HtmlBody = Ebody
.Attachments.Add "C:\Test\Document.docx"
.Attachments.Add "C:\Test\Document1.docx"
.SentOnBehalfOfName = "Financial#yahoo.com"
.Display
End With
Next
End Sub </pre>
Sub Emailer()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, y, sbody
Dim eml As Worksheet, bd As Worksheet
Dim underlyingary, ISINarray, Accountarray, i
Set eml = Sheets("Emailer"): Set bd = Sheets("Body"): Set OutApp = CreateObject("Outlook.Application")
For Each y In eml.Range("A2:A" & eml.Range("A1000000").End(xlUp).Row)
If eml.Range("F" & y.Row) <> "" Then
underlyingary = Split(eml.Range("F" & y.Row), ",")
Accountarray = Split(eml.Range("G" & y.Row), ",")
ISINarray = Split(eml.Range("H" & y.Row), ",")
For i = 0 To UBound(underlyingary)
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(underlyingary(i))) & " Account Number: " & WorksheetFunction.Proper(Trim(Accountarray(i))) & " ISIN: " & WorksheetFunction.Proper(Trim(ISINarray(i))) & "<br>" & "<br>"
Next i
Else
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(eml.Range("C" & y.Row))) & " Account Number: " & WorksheetFunction.Proper(Trim(eml.Range("D" & y.Row))) & " ISIN: " & WorksheetFunction.Proper(Trim(eml.Range("E" & y.Row))) & "<br>"
End If
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = eml.Range("A" & y.Row)
.Subject = bd.Range("B2")
.cc = eml.Range("I" & y.Row)
.htmlBody = bd.Range("A2") _
& "<br>" & "<br>" & _
bd.Range("A3") & _
Trim(eml.Range("B" & y.Row)) & _
bd.Range("A4") _
& "<br>" & "<br>" & _
sbody _
& "<br>" & _
bd.Range("A5") _
& "<br>" & "<br>" & "<li>" & _
bd.Range("A6").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A7").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A8").Text & "</li>" & _
"<br>" & "<br>" & _
bd.Range("A9") _
& "<br>" & bd.Range("A10")
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Next y
cleanup:
Set OutApp = Nothing
End Sub