I have a macro to draft automatic emails based on the recipients in each columns.
However, I'm looking for a code which can if the attachments named in the excel sheet are attached to the email. If there is any attachment missing from that email it should show a msg box with the name of the missing attachment.
SNip of one the sheets attached
Sub Email1()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
Dim FLNM As String
Dim AttchmentName As String
Set AddressList = Sheets("Tracker Summary").Range("Y:Z")
Dim AttchmentName1 As String
Dim path As String
Call FetchFileNames
path = ThisWorkbook.path & "/"
Dim i As Integer
i = 5
With olMail
ActiveSheet.Range("A1").Select
.BodyFormat = olFormatHTML
.Display
.To = ActiveSheet.Cells(2, i).Value
.CC = ActiveSheet.Cells(3, i).Value
.Subject = ActiveSheet.Cells(4, i).Value
.HTMLBody = ActiveSheet.Cells(5, i).Value & .HTMLBody
j = 6
Do Until IsEmpty(Cells(j, i))
On Error Resume Next
FLNM = ActiveSheet.Cells(j, i).Value
AttchmentName1 = Application.WorksheetFunction.VLookup(FLNM, AddressList, 1, True)
If FLNM = AttchmentName1 Then
AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
.Attachments.Add AttchmentName
End If
j = j + 1
Loop
'.Display
End With
Sheets("Tracker Summary").Range("Y:Z").ClearContents
End Sub
Presuming that AttachmentName is a full file path string, maybe your code could check if the file exists beforehand.
For the sake of simplicity...
If Len(Dir(AttachmentName)) = 0 then msgbox "The File " & AttachmentName & " is missing"
... Just after you set AttachmentName value at AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
Obviously, same for any other Attachment variables.
Related
I need to generate a series of emails that attach pdf files from specific folders. I am a novice but have some understanding of the code that I'm using. My problem is that I cannot control the number of emails being generated. I want to be able to generate the exact number of emails that there are entries in my directory (rows).
This is the code, any help would be greatly appreciated:
Sub create_email()
'On Error Resume Next
'Dim oMail As Outlook.MailItem`
'Dim num_clients, start_row As Integer`
Sheets("Control").Activate
start_row = Range("start_row").row
num_clients = Range("B100").End(xlUp).row - start_row
For i = 1 To num_clients
Set oMail = Outlook.Application.CreateItem(olMailItem)
'Subject line
oMail.Subject = Range("J9").Offset(i - 1, 0)
'Distribution list
Set RecipTo = oMail.Recipients.Add(Range("K9").Offset(i - 1, 0))
RecipTo.Type = olTo
Set RecipCC = oMail.Recipients.Add(Range("L9").Offset(i - 1, 0))
RecipCC.Type = olCC
oMail.SentOnBehalfOfName = "email#email.com.au"
oMail.Recipients.ResolveAll
'Attachments + message
oMail.Attachments.Add Range("E9").Offset(i - 1, 0) & "\" & Range("F9").Offset(i - 1, 0)
oMail.HTMLBody = "<html><p><font face=""Calibri""><font size=3>Dear Sir/ Madam,</p>" & _
"<html><p><font face=""Calibri"">Kind regards,</p>"
'Displays email pre-send
oMail.Display
Sheets("Control").Activate
Set oMail = Nothing
Next i
End Sub
Is this what you are trying? (Untested)
Sub create_email()
Dim OutApp As Object, oMail As Object
Dim wb As Workbook, ws As Worksheet
Dim i As Long, start_Rows As Long, Last_Row As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Control")
With ws
start_Row = .Range("start_row").Row '<~~ Start Row
Last_Row = .Range("B" & .Rows.Count).End(xlUp).Row '<~~ End Row
Set OutApp = CreateObject("Outlook.Application")
For i = start_Row To Last_Row '<~~ Loop from start row to end row
Set oMail = OutApp.CreateItem(0)
With oMail
.Subject = ws.Range("I" & i).Value
.To = ws.Range("J" & i).Value
.Cc = ws.Range("K" & i).Value
.SentOnBehalfOfName = "email#email.com.au"
.Attachments.Add ws.Range("D" & i).Value & "\" & ws.Range("E" & i).Value
.HTMLBody = "<html><p><font face=""Calibri""><font size=3>Dear Sir/ Madam,</p>" & _
"<html><p><font face=""Calibri"">Kind regards,</p>"
.Display
End With
Next i
End With
End Sub
I have got a workbook with 4 sheets:
1st - recipients email data such as TO, CC, Subject, from 2nd to 4th
the sheets which I need to send as an attachment to the recipients.
I made up the following script. But I faced 2 issues as a VBA beginner:
The 'loop' proposes for sending the 1st empty row from the 1st sheet
as well (I would like to stop with the last email details);
The 'ActiveWorkbook' sends all sheets (I would like to skip the 1st
one where the recipients & the VBA script are located);
I appreciate every advice/remark because I have been studying VBA for 3 months.
Thank you in advance!
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
End Sub
Have a look at this. This takes a copy of your workbook and saves it to the users "temp" location. It then does the modifications that you want to the copy of the workbook before attaching that.
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
Dim wb As Workbook, nwb As Workbook
Application.ScreenUpdating = False
Set wb = ThisWorkbook
wb.SaveCopyAs (Environ("temp") & "\temp_" & wb.Name)
Set nwb = Workbooks.Open(Environ("temp") & "\temp_" & wb.Name)
With nwb
Application.DisplayAlerts = False
' Delete relevant sheet
.Sheets(1).Delete
Application.DisplayAlerts = True
.Save
End With
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add nwb.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
nwb.Close
Application.ScreenUpdating = True
End Sub
Save a copy of your workbook
Open it
Remove the sheet from the copy
Save
Send this edited workbook
I can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub
What would be the VBA code for looping through a specific folder in outlook 2010 that is NOT the default inbox nor a subfolder of the inbox?
Dim ns As Outlook.NameSpace
Dim folder As MAPIFolder
Set ns = Session.Application.GetNamespace("MAPI")
Set folder = Please help me :-)
Thank you for any hint and help, greetings Ionic
Change
Set ns = Session.Application.GetNamespace("MAPI")
To
Set ns = Session.Application.GetNamespace("MAPI").PickFolder
This will prompt you to select the folder.
Here's a full routine that I wrote some time ago that may be of assistance, bear in mind this was written so that it could be run from Excel but should provide you with the syntax that you need:
Sub GetMail()
'// This sub is designed to be used with a blank worksheet. It will create the header
'// fields as required, and continue to populate the email data below the relevant header.
'// Declare required variables
'-------------------------------------------------------------
Dim olApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim strTo As String
Dim strFrom As String
Dim dateSent As Variant
Dim dateReceived As Variant
Dim strSubject As String
Dim strBody As String
Dim loopControl As Variant
Dim mailCount As Long
Dim totalItems As Long
'-------------------------------------------------------------
'//Turn off screen updating
Application.ScreenUpdating = False
'//Setup headers for information
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
'//Format columns E and F to
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
'//Create instance of Outlook
Set olApp = CreateObject("Outlook.Application")
'//Select folder to extract mail from
Set olFolder = olApp.GetNamespace("MAPI").PickFolder
'//Get count of mail items
totalItems = olFolder.items.Count
mailCount = 0
'//Loop through mail items in folder
For Each loopControl In olFolder.items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
'//Increase mailCount
mailCount = mailCount + 1
'//Inform user of item count in status bar
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
'//Get mail item
Set olMailItem = loopControl
'//Get Details
With olMailItem
strTo = .To
'//If strTo begins with "=" then place an apostrophe in front to denote text format
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
'//If sender displays name only, show name followed by email address e.g.(Bloggs, Joe < j.bloggs#mail.com >)
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .SentOn
dateReceived = .ReceivedTime
strSubject = .Subject
strBody = .Body
End With
'//Place information into spreadsheet
'//import information starting from last blank row in column A
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
'//Check for previous replies by looking for "From:" in the body text
'//Check for the word "From:"
If InStr(0, strBody, "From:") > 0 Then
'//If exists, copy start of email body, up to the position of "From:"
.Offset(0, 3).Value = Mid(strBody, 1, InStr(1, strBody, "From:") - 1)
Else
'//If doesn't exist, copy entire mail body
.Offset(0, 3).Value = strBody
End If
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
'//Release item from memory
Set olMailItem = Nothing
End If
'//Next Item
Next loopControl
'//Release items from memory
Set olFolder = Nothing
Set olApp = Nothing
'//Resume screen updating
Application.ScreenUpdating = True
'//reset status bar
Application.StatusBar = False
'//Inform user that code has finished
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
Okay, I've found it myself.
Set folder = ns.GetDefaultFolder(olFolderInbox).Parent.Folders(NAME OF THE FOLDER)
Than you for your help guys !
I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?
Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?
Code:
Sub SplitFile()
Dim rTemp As Range
Dim regions() As String
Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
Set wb = Workbooks.Add
ThisWorkbook.Sheets("DVal").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
With ThisWorkbook.Sheets("Combined")
.AutoFilterMode = False
' .AutoFilter
.Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
Application.DisplayAlerts = False
.Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
Application.DisplayAlerts = True
For c = 1 To 68
wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
With wb
.Sheets("Sheet1").Activate
.SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
.Close True
End With
Set wb = Nothing
Next N
End Sub
I am assuming you want to do it programmaticaly using VB, you can do something like
Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage()
msg.From = "noone#nobody.com"
msg.To = "someone#somewhere.com"
msg.Subject = "Email with Attachment Demo"
msg.Body = "This is the main body of the email"
Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls")
msg.Attachments.Add(attch)
SmtpMail.Send(msg)
If you're having trouble with the above, my mail macro is different; this is used with excel 2007:
Sub Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
"This is a test!" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.to = "anyone#anywhere.com"
.cc = ""
.BCC = ""
.Subject = "This is only a test"
.Body = strbody
'You can add an attachment like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Jon
I am assuming the following.
1) Regions are in Col AH
2) Contacts are in Col AI
3) UniqueItems() in your code removes duplicates?
Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.
NOTE: I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.
Option Explicit
Sub SplitFile()
'~~> Excel variables
Dim wb As Workbook, wbtemp As Workbook
Dim rTemp As Range, rng As Range
Dim regions() As String, FileExt As String, flName As String
Dim N As Long, FileFrmt As Long
'~~> OutLook Variables
Dim OutApp As Object, OutMail As Object
Dim strbody As String, strTo As String
On Error GoTo Whoa
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'~~> Just Regions
Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
'~~> Regions and Email address. We wil require this later
'~~> Tofind email addresses
Set rng = wb.Sheets("Combined").Range("AH2:AI1455")
regions = UniqueItems(rTemp, False)
'~~> Create an instance of outlook
Set OutApp = CreateObject("Outlook.Application")
For N = 1 To UBound(regions)
Set wb1 = Workbooks.Add
wb.Sheets("DVal").Copy after:=wb1.Sheets(1)
With wb.Sheets("Combined")
.AutoFilterMode = False
With .Range("A1:BP1455")
.AutoFilter Field:=34, Criteria1:=regions(N)
'~~> I think you want to copy the filtered data???
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
wb1.Sheets("Sheet1").Range("A1")
For c = 1 To 68
wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
wb.Columns(c).ColumnWidth
Next c
End With
End With
'~~> Set the relevant Fileformat for Save As
' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)
FileFrmt = 52
Select Case FileFrmt
Case 50: FileExt = ".xlsb"
Case 51: FileExt = ".xlsx"
Case 52: FileExt = ".xlsm"
Case 56: FileExt = ".xls"
End Select
'~~> Contruct the file name.
flName = "H:\" & regions(N) & " 14-12-11" & FileExt
'~~> Do the save as
wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
wb1.Close SaveChanges:=False
'~~> Find the email address
strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)
'~~> Create new email item
Set OutMail = OutApp.CreateItem(0)
'~~> Create the body of the email here. Change as applicable
strbody = "Dear Mr xyz..."
With OutMail
.To = strTo
.Subject = regions(N) & " 14-12-11" '<~~ Change subject here
.Body = strbody
.Attachments.Add flName
'~~> Uncomment the below if you just want to display the email
'~~> and comment .Send
'.Display
.Send
End With
Next N
LetContinue:
Application.ScreenUpdating = True
'~~> CleanUp
On Error Resume Next
Set wb = Nothing
Set wb1 = Nothing
Set OutMail = Nothing
OutApp.Quit
Set OutApp = Nothing
On Error GoTo 0
Whoa:
MsgBox Err.Description
Resume LetContinue
End Sub