I am trying to attach a file to outlook using VBA, however my code always seems to attach a blank file.
The code currently saves a workbook in a pre-defined path and then adds a file by the same name as an attachment to outlook but the file attached is blank and I'm not sure why. This "blank" file does not appear to be saved anywhere by the code so not sure where it is coming from.
Dim NewWkb As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim COB As Variant
COB = Range("B16").Value
COB = Format(COB, "DD_MMM_YYYY")
Application.DisplayAlerts = False
Set NewWkb = Workbooks.Add
NewWkb.SaveAs "C:\Users\Documents\BS_Spray " & COB
For i = 2 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Sheets(i).Copy NewWkb.Worksheets(NewWkb.Worksheets.Count)
Next
Sheets("sheet1").Delete
Application.DisplayAlerts = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = " "
.Subject = "SL Utility B/S Report " & J
.Body = "Hi all," & vbNewLine & vbNewLine & "Please see attached " & J
.Attachments.Add NewWkb.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You should pass "C:\Users\Documents\BS_Spray " & COB to .Attachments.Add
Related
I want to send to a list of email addresses in my workbook.
How would I go about that with what I have for the mailing section of my code?
I want to have column R named mailing list and it will send to whatever email addresses are inserted into that column/list all together.
Sub SendReminderMail1()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = " "
.CC = ""
.BCC = ""
.Subject = "Rotations needed for ."
.Body = "Hey there, equipment needs to be rotated."
.Attachments.Add wb2.FullName
.Display 'or use .Send to send with display proof reading
End With
On Error GoTo 0
wb2.Close savechanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your Automated Email for BP Rotations was successfully ran at " & TimeValue(Now), vbInformation
End Sub
In your code I've you set the recipients fields to empty strings:
With OutMail
.To = " "
.CC = ""
.BCC = ""
Instead, you need to read values from the column R and add recipients for the email. To add recipients I'd recommend using the Recipients collection which can be retrieved using the corresponding property of the MailItem class.
Dim recipients As Outlook.Recipients = Nothing
Set recipients = mail.Recipients
' now we add new recipietns to the e-mail
recipientTo = recipients.Add("Eugene")
recipientTo.Type = Outlook.OlMailRecipientType.olTo
recipientCC = recipients.Add("Dmitry")
recipientCC.Type = Outlook.OlMailRecipientType.olCC
recipientBCC = recipients.Add("eugene.astafiev#somedomain.com")
recipientBCC.Type = Outlook.OlMailRecipientType.olBCC
recipients.ResolveAll()
Read more about that in the How To: Fill TO,CC and BCC fields in Outlook programmatically article.
Mail Merge not your cup of tea huh...
Maybe what you need is a Do while Loop where it references a cell in a Table of people, then moves down each step till the E-mail is blank just chugging through Row after Row of E-mails driving that sweet CPU usage up.
Like a user programmed Mail Merge but in Excel and not in a Word Processor... Like Mail Merge... In Word, but not in Word, In Excel In VBA...
I generate reports to send to different branches. I run a macro that creates protected reports (*.xlsm). These reports have a space for comments for the Branch Managers, with a "send Comments" button that run this macro below.
I suggested the following references to add if the macro does not work.
The Branch Managers have different versions of MS Office (Excel, Outlook, etc.) on their laptops. When they try to Run, it shows errors, such as: "Error in Loadind DLL"; Error2, etc.
What should be done on the Branch Managers side to run this Macro?
Sub CommentsEmail()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Shell ("Outlook")
Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
template.Activate
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor
Set objSel = wordDoc.Windows(1).Selection
'construct the body of the email here
With objSel
'first text
.InsertAfter "Dear All," & vbCrLf
.Move wdParagraph, 1
'second text
.InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
.Move wdParagraph, 1
'copy a range and paste a picture
commentsrange.Copy ''again, you need to modify your target range
.PasteAndFormat wdChartPicture
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Kind Regards," & vbCrLf
End With
OutMail.To = OutMail.To & ";" & Sendto
With OutMail
.Subject = "Comments on Flash Indicator Results - " & branch
.Attachments.Add (ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Is this still early binding? If yes, I am totally lost.
Sub CommentsEmail2()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object
Dim TempFilePath As String
Dim xHTMLBody As String
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
template.Activate
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OleMail = olApp.CreateItem(0)
Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With OleMail
.Subject = "test"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Attachments.Add (ActiveWorkbook.FullName)
.To = " "
.Cc = " "
.Display
End With
Set OleMail = Nothing
Set OlaApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(comments).Activate
Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
I found a code that turns a range of cell in Excel to a photo. That photo is delivered by mail. The problem is that when i'm using .Display everything is OK but when i'm using .Send the message sent empty.
Here is the code:
Sub Send_Pt_mail()
Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String
Dim ch As ChartObject
'Prepare screen data file
Set ch = Worksheets("Chart").ChartObjects.Add(Range("Photo2Mail").Left, Range("Photo2Mail").Top, Range("Photo2Mail").Width, Range("Photo2Mail").Height)
'calculating the number of Recipients
iRow = Worksheets("Recipients").Cells(Rows.Count, 1).End(xlUp).Row
Recipients = ""
For i = 2 To iRow
'for each record in Recipients sheet an eMail will be send
If ThisWorkbook.Worksheets("Recipients").Cells(i, 2).Value = ThisWorkbook.Worksheets("Recipients").Cells(2, 7).Value Then
Recipients = Recipients & ThisWorkbook.Worksheets("Recipients").Cells(i, 1) & ";"
End If
Next i
'Prepare mail range as an image
Application.ScreenUpdating = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Fname = Environ$("temp") & "Mail_snap" & ".gif"
'select the relevant table (update or new data) and export through Chart to file
'then select the charts in dashboard and export through Chart 18 to file
ch.Chart.ChartWizard Source:=Worksheets("DB").Range("Photo2Mail"), gallery:=xlLine, Title:="New Chart"
' ch.Chart.ChartArea.ClearContents
' ch.Width = 1700
' ch.Height = 900
Chart_Name = ch.Name
Worksheets("DB").Activate
Range("Photo2Mail").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Worksheets("Chart").ChartObjects(Chart_Name).Activate
ActiveChart.Paste
ActiveWorkbook.Worksheets("Chart").ChartObjects(Chart_Name).Chart.Export Filename:=Fname, FilterName:="gif"
S = "<img src=" & Fname & "><br>"
'On Error Resume Next
With OutMail
.To = Recipients
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Worksheets("Recipients").Cells(3, 4) & " " & Format(Now(), "dd/mm/yyyy")
.Save
.HTMLBody = S
' send
.display
End With
On Error GoTo 0
Kill Fname
ch.Delete
StopMacro:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = False
If (ActiveWindow.Zoom <> 100) Then
ActiveWindow.Zoom = 100
End If
End Sub
If the mail body is not updated before sending then .GetInspector will act as .Display, except for not displaying. The idea is usually associated with generating default signatures especially when the flash associated with display is annoying.
Sub Send_With_Signature_Demo()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "myaddress#somewhere.com"
.Subject = Format(Now(), "dd/mm/yyyy")
' If you have a default signature
' you should find you need either .GetInspector or .Display
.GetInspector
.Save
.Send
End With
StopMacro:
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
In excel I have the following code which sends out emails for every cell that contains an email address in column K.
This would work except for the header in the table isn't an email address, so it breaks the code. I tried to skip the header by specifying "if cell.value = CONTACT METHOD, which is the header name text, then go to Next cell"
but this causes a "Next without for" error.
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
If your goal is to skip cell K1 in looping down column K then:
For Each cell In Columns("K2:K" & Rows.Count).Cells.SpecialCells(xlCellTypeConstants)
You can enclose the code within the FOR/EACH loop within a separate IF statement, as below:
Sub Mail_small_Text_Outlook()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("K").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "CONTACT METHOD" Then
'Do Nothing, or Enter code here
Else
If cell.Value Like "*#*" Then
finaladdress = cell.Value
Else
finaladdress = cell.Value & "#email.smsglobal.com"
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = finaladdress
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Currently I have a sheet that sends a email to a specific email address, on this sheet there is a specific validation list with two options. If I select one option it will send an email to the email specified. However if I select the second option nothing happens. And there is no error.
I would like to be able to send the sheet two different email address depending on what has been selected within the list, and press click on the send button.
Code:
Private Sub CommandButton1_Click()
If Sheet1.Range("G31") = "in the cell(see notes below)" Then
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim fName As String
fName = " NIFU - " & ws.Range("Q12") & " " & Format(Now, "ddmmyyyy hhmmss") & ".xls"
ThisWorkbook.SaveAs fPath & fName, xlWorkbookNormal
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI# "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
Else
If Sheet1.Range("G31") = "Multiple applicants registered at the same address" Then
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI#__________ "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
End If
End If
End Sub
I just figured out why it was fundamentally not working. You need to declare and set your objects inside both branches of the IF. The way it's setup right now, you declare them in the top block, but not the bottom one.
You need to have those lines in the Else part as well :
dim OutApp as object
Set OutApp = CreateObject("Outlook.Application")
dim OutMail as object
set OutMail = OutApp.CreateItem(0)
Try this code out :
Private Sub CommandButton1_Click()
If Sheet1.Range("G31") = "in the cell(see notes below)" Then
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim fName As String
fName = " NIFU - " & ws.Range("Q12") & " " & Format(Now, "ddmmyyyy hhmmss") & ".xls"
ThisWorkbook.SaveAs fPath & fName, xlWorkbookNormal
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI# "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
ElseIf Sheet1.Range("G31") = "Multiple applicants registered at the same address" Then
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI#__________ "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
End If
End Sub
I have initialised the Outlook variables toward outside the If statement and it now seems to work.
Private Sub CommandButton1_Click()
dim OutApp as object
Set OutApp = CreateObject("Outlook.Application")
dim OutMail as object
set OutMail = OutApp.CreateItem(0)
If Sheet1.Range("G31") = "in the cell(see notes below)" Then
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim fName As String
fName = " NIFU - " & ws.Range("Q12") & " " & Format(Now, "ddmmyyyy hhmmss") & ".xls"
ThisWorkbook.SaveAs fPath & fName, xlWorkbookNormal
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
' This example sends the last saved version of the Activeworkbook object .
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR#"
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
ElseIf Sheet1.Range("G31") = "Multiple applicants registered at the same address" Then
' Change the mail address and subject in the macro before you run it.
With OutMail
.To = "JABAAR.ALI#__________ "
.CC = ""
.BCC = ""
.Subject = "RESTRICTED:"
.Body = "Hello," & vbNewLine & vbNewLine
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you, this referral has been sucessfully sent"
End If
End Sub