I have found a lot of examples using KuTools, but I don't want this to be interactive, I want the dates in my spreadsheet to trigger an email to be sent.
So the issue I am currently having, is that the Ranges I am trying to fetch are being returned as Nothing, hence, my program doesn't work. Hope someone can help me.
Public Sub sendEmail()
Dim dueDates As Excel.Range
Dim certs As Excel.Range
Dim remainingDays As Long
Dim triggerDate As Long
Set dueDates = ThisWorkbook.Worksheets("worksheetName").Range("D3:D12")
Set certs = ThisWorkbook.Worksheets("worksheetName").Range("C3:C12")
remainingDays = 90
triggerDate = today.AddDays(remainingDays)
Dim toWhom As Excel.Range
Dim subject As String
Dim bodyOpen As String
Dim bodyClose As String
Dim bodyFull As String
Dim mail As Object
Dim outlook As Object
Set toWhom = ThisWorkbook.Worksheets("worksheetName").Range("B16")
subject = "Cert renewal reminder"
bodyOpen = "<HTML><BODY><br>"
bodyClose = "<br></HTML></BODY>"
bodyFull = ""
On Error Resume Next
For Each cell in dueDates
If cell.Value Is Nothing Then Exit Sub (my code is breaking at this line)
If cell.Value <> "" Then
If cell.Value < triggerDate Then
remainingDays = cell.Value - today
bodyFull = bodyOpen + "Certificate " + certs.ActiveCell.row.Value + " will expire in " + remainingDays + " days.<br>Official expiration day = " + cell.Value + ".<br>Please schedule renewal soon<br>" + bodyClose
Set outlook = CreateObject("Outlook.Application")
Set mail = outlook.CreateItem(0)
If toWhom <> "" Then
With mail
.subject = subject
.To = toWhom
.HTMLBody = bodyFull
.Display
.Send
End With
On Error GoTo 0
Set mail = Nothing
End If
End If
End If
End If
Next cell
Set outlook = Nothing
End Sub
This is my first macro, never used VBA before so I may be miss-using types and such things, any advise is taken.
Related
When I go to sent emails with the code below it sends a previous version of the email. It doesn't reset.
Private Sub CommandButton16_Click()
Dim EmailApp As Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailApp = New Outlook.Application
Dim EmailAddress As String
Dim EmpName As String
Dim ProvName As String
Dim PayMonth As String
Dim Filename As String
Dim Filepath As String
Dim FileExists As String
Dim Subject As String
Dim Source As String
Dim AltEmail As String
Dim ExtraMsg As String
Dim i As Long
'Loop through and get email address and names
i = 2
PayMonth = TextBox6.Value
AltEmail = TextBox7.Value
ExtraMsg = TextBox8.Value
Do While Worksheets("Provider Template").Cells(i, 1).Value <> ""
ProvName = Worksheets("Provider Template").Cells(i, 1).Value
EmpName = Worksheets("Provider Template").Cells(i, 11).Value
If AltEmail = "" Then EmailAddress = Worksheets("Provider Template").Cells(i, 20).Value Else EmailAddress = AltEmail
Filename = ProvName & " " & PayMonth
Filepath = ThisWorkbook.Path & "\Remittance PDFs\"
Source = Filepath & Filename & ".pdf"
Subject = "Monthly Remittance Advice for" & " " & ProvName & " - " & PayMonth
FileExists = Dir(Source)
If FileExists = "" Then GoTo Lastline Else GoTo SendEmail
SendEmail:
Set EmailItem = EmailApp.CreateItem(olMailItem)
With EmailItem
EmailItem.To = EmailAddress
EmailItem.CC = "******************"
EmailItem.Subject = Subject
EmailItem.HTMLBody = "<html><body><p>Here is the tax invoice and calculation sheet for " & ProvName & ".</p><p>" & ExtraMsg & "</p><p>Kind regards, ******</p><p>****** ******</p><p>Practice Manager</p></body></html>"
EmailItem.Attachments.Add Source
EmailItem.Send
End With
GoTo Lastline
Lastline:
i = i + 1
Loop
End Sub
I thought it was a problem in the code then I ran it on a different machine and fresh emails were sent. I uploaded the updated version to a work machine and the old emails are going again, like there is a cache of this stuff somewhere.
You can try to check your "Sent" box in outlook next time. It's possible that outlook did'nt sent them (offline or other reason),thety are still there as a draft. That could be the reason that they where sent later.
And adjust:
With EmailItem .To = EmailAddress
And you can leave this out;
GoTo Lastline Lastline:
I used the below coding earlier for some other type of mail but this time is not sending the mails.
Also not picking the email IDs and data given in Excel.
I have to send mails to different people with CC to their respective managers. I updated their Email IDs in Excel but the details updated in Excel are not taking and a draft mail is created without anything in To and CC.
Sub Send_Recertification_From_Excel()
Dim oXlWkBk As Excel.Workbook ' Excel Work Book Object
Dim oOLApp As Outlook.Application
Dim oOLMail As MailItem
Dim lRow As Long
Dim olMailItem
Dim sMailID As String
Dim sSalutation As String
Dim sName As String
Dim sDetails As String
Dim sSubject As String
Dim mailsSentString As String
Dim templateName As String
templateName = "C:\Users\m540797\Desktop\Recertification\Recertifications"
On Error GoTo Err_Trap
Set oXlWkBk = ActiveWorkbook
Set oOLApp = GetObject(, "Outlook.Application")
If oOLApp Is Nothing Then
MsgBox "Please Open Outlook.."
Exit Sub
End If
Dim i As Integer
For i = 6 To 50
If Len(Trim(Sheet1.Cells(i, 1))) > 1 Then
Set oOLMail = oOLApp.CreateItemFromTemplate(templateName)
sMailID = Sheet1.Cells(i, 4)
sSubject = "Recertification"
With oOLMail
.BodyFormat = olFormatHTML
.HTMLBody = Replace(.HTMLBody, "<NAME>", Sheet1.Cells(i, 3))
.SentOnBehalfOfName = "my mail ID given here"
.To = sMailID
.Subject = sSubject
.CC = Sheet1.Cells(i, 6)
.Send
End With
oOLMail.Send
Else
Exit For
End If
Next i
MsgBox "Mails successfully sent to :" + vbCrLf + mailsSentString + vbCrLf + "with using the template :" + templateName
Destroy_Objects:
If Not oOLApp Is Nothing Then Set oOLApp = Nothing
Err_Trap:
If Err <> 0 Then
MsgBox Err.Description, vbInformation, "VBADUD AutoMail"
Err.Clear
GoTo Destroy_Objects
End If
End Sub
Not giving any error just says mail sent successfully but it is lying in draft.
If someone could help me from going insane, my mother would appreciate it.
I have a long list of email addresses (many repeats) with associated Audit Locations. Basically I need to create one email for each email address and populate said email body with a list of all the associated Audit Locations.
e.g.
Column One (Email Address) | Column 2 (Audit Location)
Yoda1#lightside.org | Coruscant
Yoda1#lightside.org | Death Star
Yoda1#lightside.org | Tatooine
Vader#Darkside.org | Death Star
Vader#Darkside.org | Coruscant
Jarjar#terrible.org | Yavin
So far I have created a CommandButton Controlled vba that takes Column One and makes it unique in a new worksheet.
Then I have another sub that creates an email for each unique email address. But I am stuck on the "If...Then" statement. Essentially, I want to add the information in Column 2 (Audit Location) if the Recipient of the email is the email address in Column One and then continue to append to the email body until the email address no longer equals the recipient email address. Any guidance would be huge.
Private Sub CommandButton1_Click()
Call MakeUnique
Call EmailOut
End Sub
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A:A").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheets.Add.Name = "Unique"
ActiveSheet.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
Sub EmailOut()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next
Dim cell As Range
For Each cell In Worksheets("Unique").Columns("a").Cells.SpecialCells(xlCellTypeConstants)
recip = cell.Value
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
For Each org In Columns("b").Cells.SpecialCells(xlCellTypeConstants)
If org.Value Like recip Then
xMailBody = "Body content" & vbNewLine & vbNewLine & _
"This is line 1" & " " & cell.Offset(0, 3).Value & vbNewLine & _
[B5] & vbNewLine & _
"This is line 2"
End If
Next org
On Error Resume Next
With xOutMail
.To = recip
.CC = ""
.BCC = ""
.Subject = cell.Offset(0, 2).Value & " " & cell.Offset(0, 3).Value & " " & "Remittance Advice"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
Next
End Sub
Based on your example I quickly wrote the following:
Option Explicit
Public Sub SendEmails()
Dim dictEmailData As Object
Dim CurrentWorkBook As Workbook
Dim WrkSht As Worksheet
Dim rngToLookUp As Range
Dim lngLastRow As Long, i As Long
Dim arryEmailData As Variant
Dim objOutlookApp As Object, objOutlookEmail As Object
Dim varKey As Variant
Application.ScreenUpdating = False
Set CurrentWorkBook = Workbooks("SomeWBName")
Set WrkSht = CurrentWorkBook.Worksheets("SomeWSName")
lngLastRow = WrkSht.Cells(WrkSht.Rows.Count, "A").End(xlUp).Row 'Find last row with data
Set rngToLookUp = WrkSht.Range("A2:B" & lngLastRow) 'set range for last row of data
arryEmailData = rngToLookUp.Value2 'Get the email data from the sheet into an array
Set dictEmailData = CreateObject("Scripting.Dictionary") 'set the dicitonary object
On Error GoTo CleanFail
For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)
varKey = UCase(Trim(arryEmailData(i, 1)))
If Not dictEmailData.Exists(varKey) Then
dictEmailData(varKey) = vbNewLine & vbNewLine & Trim(arryEmailData(i, 2))
Else
dictEmailData(varKey) = dictEmailData(varKey) & vbNewLine & Trim(arryEmailData(i, 2))
End If
varKey = Empty
Next i
'for each unique key in the dicitonary
'get the corresponding item
'created in the loop above
Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
Dim Msg As String, MailBody As String
For Each varKey In dictEmailData.Keys
Msg = dictEmailData.Item(varKey)
Set objOutlookEmail = objOutlookApp.CreateItem(0)
MailBody = "Dear Colleague," & Msg
With objOutlookEmail
.To = varKey
.Subject = "Remittance Advice"
.Body = MailBody
.Send
End With
Set objOutlookEmail = Nothing
Msg = Empty: MailBody = Empty
Next
MsgBox "All Emails have been sent", vbInformation
CleanExit:
Set objOutlookApp = Nothing
Application.ScreenUpdating = True
Exit Sub
CleanFail:
Resume CleanExit
End Sub
Add the first occurrence of a varKey = email address to the dictionary dictEmailData along with its corresponding item dictEmailData(varKey) = Email body. On the next occurrence of the email address, append to the Email body. Once the dictionary is built, loop through it and send the emails
Printing to the immediate window yields:
Below code displays e-mail creation screen in outlook each time i run it. i tried removing .display from the second function but it gives run-time error.
I am new to VBA macros ,Please advice on how to hide the e-mail creation screen for each new e-mail that is being triggered. thanks a lot in advance.
Public Sub loopCheck()
Dim NumRows As Integer
Dim eID As String
Dim eName As String
Dim eEmail As String
Dim supportGroup As String
Dim managerEmail As String
Dim acName As String
Dim x As Integer
Application.ScreenUpdating = False
NumRows = Worksheets("Data").Range("A5", Range("A5").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
Worksheets("Data").Range("A5").Select ' Select first record.
For x = 1 To NumRows ' Establish "For" loop to loop "numrows" number of times.
eID = Worksheets("Data").Range("A" & x + 4).Value
eName = Worksheets("Data").Range("B" & x + 4).Value
eEmail = Worksheets("Data").Range("C" & x + 4).Value
supportGroup = Worksheets("Data").Range("F" & x + 4).Value
managerEmail = Worksheets("Data").Range("G" & x + 4).Value
acName = Worksheets("Data").Range("I" & x + 4).Value
'Prepare table to be sent locally.
Worksheets("Data").Range("AA5").Value = eID
Worksheets("Data").Range("AB5").Value = eName
Worksheets("Data").Range("AC5").Value = eEmail
Worksheets("Data").Range("AF5").Value = supportGroup
managerEmail = managerEmail + ";" + Worksheets("Data").Range("AA1").Value
'Call Emails function.
Call Emails(eEmail, managerEmail)
ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
Public Sub Emails(y As String, z As String)
Dim outlook As Object
Dim newEmail As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim a As String
Dim b As String
a = y
b = z
Set outlook = CreateObject("Outlook.Application")
Set newEmail = outlook.CreateItem(0)
With newEmail
.To = a
.CC = b
.BCC = ""
.Subject = "test loop"
.Body = ""
.display
Set xInspect = newEmail.GetInspector
Set pageEditor = xInspect.WordEditor
Worksheets("Data").Range("AA4:AF5").Copy
pageEditor.Application.Selection.Start = Len(.Body)
pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
.display
.send
Set pageEditor = Nothing
Set xInspect = Nothing
End With
Set newEmail = Nothing
Set outlook = Nothing
End Sub
You have two instances of .display in your Emails sub .If first instance is suppressed it locks the editor and would not allow program to run. Second instance can be commented out and .send is enough for program working. Still first instance will display on screen . In order to totally disable e-mail creation screen display please take reference from programs at roundebruin which covers all types of possibilities of sending emails without displaying email creation screen. Method followed by you is a preferred method for embedding of images or charts in the HTML body.
your adopted code is similar to SO Question . Please refer to opening comments in Answer by Dmitry Streblechenko " --
You should also use MailItem.GetInspector instead of
Application.ActiveInspector since the message is not yet displayed.
So if you want to suppress e-mail creation screen display, please adopt other approach as suggested earlier.
Further Eugene Astafiev also mentioned while answering a question HERE
That's a known issue in Outlook. You have to call the Display method first to get the inspector visible.
Otherwise it won't work.
I think you can not suppress display of e-mail creation screen display by invoking this approach.
Error in code to send email through Excel 2016.
Method 'To' of object '_Mailitem' Failed
The same code works in Excel 2010.
Sub TrainingMails()
For I = 2 To Range("A65536").End(xlUp).Row
Application.Wait (Now + TimeValue("0:00:1"))
Set myOlApp = CreateObject("Outlook.Application")
Set mail = myOlApp.CreateItem(olmailitem)
Set attach = mail.Attachments
mail.To = Cells(I, 1)
mail.CC = Cells(I, 2)
mail.BCC = Cells(I, 3)
mail.Subject = Cells(I, 4)
mail.Body = Cells(I, 5)
If Cells(I, 6) <> "" Then
attach.Add "" & Cells(I, 6) & ""
End If
mail.Display
Set myOlApp = Nothing
Set mail = Nothing
Set attach = Nothing
Next
End Sub
Using Option Explicit at top of the module forces some variable declaration. I have nudged along your code. Folding in your comment about the error I have added an error handler, this code will now skip the problematic mail and continue. I would still be interested to know what is in the cell that is causing a problem.
Option Explicit
Function To_WithErrorHandler(ByVal mail As Object, ByVal v) As Boolean
On Error GoTo ErrorHandler
If IsError(v) Then
Debug.Print "#Attempt to set To field with #NAME! or #REF!"
Else
If Not IsValidEmailAddress(v) Then
Debug.Print "#Warning: attempt to set To field to '" & v & "' which is not a valid email address!"
End If
mail.To = v
To_WithErrorHandler = True
End If
Exit Function
ErrorHandler:
MsgBox "#Could not set To field of mail object to the value (v) '" & v & "'!"
Stop
End Function
Function IsValidEmailAddress(ByVal sEmail As String) As Boolean
Static reEmail As Object 'VBScript_RegExp_55.RegExp
If reEmail Is Nothing Then
Set reEmail = CreateObject("VBScript.RegExp")
reEmail.Pattern = "^\w+#[a-zA-Z_]+?\.[a-zA-Z]{2,3}$"
End If
IsValidEmailAddress = reEmail.Test(sEmail)
End Function
Sub TrainingMails()
Dim I As Long
Dim wb As Excel.Workbook
Set wb = Application.Workbooks.Item("ULTIMATE ETO.xlsm") '<----- change this is required
Dim ws As Excel.Worksheet
Set ws = wb.Worksheets.Item("ETO") '<----- change this is required
'Excel Macro: What is olmailitem constant value
'http://excel-vba-macros.blogspot.co.uk/2013/05/what-is-olmailitem-constant-value.html
Const olmailitem As Long = 0
Dim myOlApp As Object
Set myOlApp = CreateObject("Outlook.Application")
For I = 2 To ws.Range("A65536").End(xlUp).Row
Application.Wait (Now() + TimeValue("0:00:01"))
Dim mail As Object
Set mail = myOlApp.CreateItem(olmailitem)
Dim attach As Object
Set attach = mail.Attachments
Dim bOk As Boolean
'mail.To = Cells(I, 1)
bOk = To_WithErrorHandler(mail, ws.Cells(I, 1))
If bOk Then
mail.CC = ws.Cells(I, 2)
mail.BCC = ws.Cells(I, 3)
mail.Subject = ws.Cells(I, 4)
mail.Body = ws.Cells(I, 5)
If ws.Cells(I, 6) <> "" Then
attach.Add "" & ws.Cells(I, 6) & ""
End If
mail.Display
End If
Set mail = Nothing
Set attach = Nothing
Next
Set myOlApp = Nothing
End Sub
Sub TestIsValidEmailAddress()
Debug.Assert IsValidEmailAddress("nancydavolio#northwind.com")
Debug.Assert Not IsValidEmailAddress("nancydavolionorthwind.com")
End Sub
but I cannot run as I do not have Outlook installed.