I am trying to create a macro to send automated reminders.
I am sending below the two macros:
Sub Auto_Open()
Dim vResp As Variant, dTime As Date
vResp = MsgBox("Inviare email ora?", vbYesNo)
If vResp = 6 Then 'YES
Call EmailReminder
ElseIf vResp = 7 Then 'NO
dTime = CDate(InputBox("Send email at:", , Time + TimeValue("00:00:10")))
Do Until Time = dTime 'OR = #8:00:00 AM#
DoEvents
Loop
Call EmailReminder
End If
End Sub
Sub EmailReminder()
Dim oOL As Outlook.Application, oMail As Outlook.MailItem, oNS As Outlook.Namespace
Dim oMapi As Outlook.MAPIFolder, oExpl As Outlook.Explorer
Dim sBody As String, dDate As Date
Dim oWS As Worksheet, r As Long, i As Long, sStart As String
Set oWS = Foglio1
Set oOL = New Outlook.Application
Set oExpl = oOL.ActiveExplorer
If TypeName(oExpl) = "Nothing" Then
Set oNS = oOL.GetNamespace("MAPI")
Set oMapi = oNS.GetDefaultFolder(olFolderInbox)
Set oExpl = oMapi.GetExplorer
End If
With oWS.Range("E1")
r = .CurrentRegion.Rows.Count
For i = 1 To r
dDate = .Cells(i, 1)
sBody = "Oggi è il compleanno di" & .Cells(i, 2) & dDate & .Cells(i, -4) & " " & .Cells(i, -3) & vbCrLf & "Facciamo i nostri auguri!"
If Date = dDate Or Date = Int(dDate) Then ' Use INT to eliminate time info
Set oMail = oOL.CreateItem(oIMailItem)
With oMail
.Recipients.Add "umberto.roselli#openfiber.it" 'Indirizzo ricevente
.Subject = "Nuovo compleanno oggi:" & .Cells(i, -4) & " " & .Cells(i, -3) & .Body = sBody: .Send
End With
End If
Next i
End With
MsgBox "Messaggio email inviato correttamente!"
End Sub
I keep getting, however, on the second macro the error Run-Time 13: Type not matching but it doesn't give me any indication where the error is.
Can you help me out?
Thank you very much in advance
Fyi
Private Sub Workbook_Open()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For i = 2 To Range("e65536").End(xlUp).Row
If Cells(i, 8) <> "Y" Then
If Cells(i, 5) - 7 < Date Then
strto = Cells(i, 7).Value 'email address
strsub = Cells(i, 1).Value & " " & Cells(i, 2).Value & " compleanno il " & Cells(i, 5).Value 'email subject
strbody = "Il compleanno di " & Cells(i, 1).Value & " " & Cells(i, 2).Value & " sarà il " & Cells(i, 5).Value & vbNewLine 'email body
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Send
End With
Cells(i, 8) = "Mail Sent " & Now()
Cells(i, 9) = "Y"
End If
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Related
I need to send reminders 7 days before a certain deadline.
With help I managed to create this code:
Private Sub Workbook_Activate()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
For i = 2 To Range("e65536").End(xlUp).Row
If Cells(i, 9) <> "Y" Then
If Cells(i, 5) - 7 < Date Then
strto = Cells(i, 7).Value 'email address
strsub = Cells(i, 1).Value & " " & Cells(i, 2).Value & " compleanno il " & Cells(i, 5).Value 'email subject
strbody = "Il compleanno di " & Cells(i, 1).Value & " " & Cells(i, 2).Value & " sarà il " & Cells(i, 5).Value & vbNewLine 'email body
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Send
End With
Cells(i, 8) = "Mail Sent " & Now()
Cells(i, 9) = "Y"
End If
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I have to start it manually every day because even if the deadline is updated the macro doesn't restart by itself.
I tried replacing Sub Workbook_Activate() with Sub Workbook_SelectionChange(ByVal Target As Range).
I can send email to multiple recipients with a click of a button in Excel with this code.
The problem comes when marking it with time. If I send email to one recipient the whole column will be marked with the time and mark of that one recipient and ignore the others.
This is my code in Module1 and a class called Class1
This is the code in Module1
Sub Button4_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim sSendTo As String
Dim sSendCC As String
Dim sSendBCC As String
Dim sSubject As String
Dim sTemp As String
Set OutApp = CreateObject("Outlook.Application")
Set itmevt.itm = Nothing
OutApp.Session.Logon
sSendTo = Range("D3")
sSendCC = ""
sSendBCC = ""
sSubject = "Due date reached"
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 3 To lLastRow
If Cells(lRow, 5) <> "Email sent" Then
If Cells(lRow, 3) <= Date Then
Set OutMail = OutApp.CreateItem(0)
Set itmevt.itm = OutMail
With OutMail
.To = sSendTo
If sSendCC > "" Then .CC = sSendCC
If sSendBCC > "" Then .BCC = sSendBCC
.Subject = sSubject
sTemp = "Hello!" & vbCrLf & vbCrLf
sTemp = sTemp & "The due date has been reached "
sTemp = sTemp & "for this project:" & vbCrLf & vbCrLf
sTemp = sTemp & " " & Cells(lRow, 2)
sTemp = sTemp & vbCrLf & vbCrLf & " Please take the appropriate"
sTemp = sTemp & " action." & vbCrLf
sTemp = sTemp & "Regards," & vbCrLf
sTemp = sTemp & "Danial " & vbCrLf
.Body = sTemp
.Display
End With
Set OutMail = Nothing
End If
End If
Next lRow
Set OutApp = Nothing
End Sub
This is the code in Class1
Option Explicit
Public WithEvents itm As Outlook.MailItem
Private Sub itm_Close(Cancel As Boolean)
Dim lLastRow As Long
Dim lRow As Long
Dim blnSent As Boolean
On Error Resume Next
blnSent = itm.Sent
lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 3 To lLastRow
If Cells(lRow, 5) <> "Email sent" Then
If Cells(lRow, 3) <= Date Then
If Err.Number = 0 Then
Cells(lRow, 5) = "Email not sent"
Cells(lRow, 6) = "X"
Cells(lRow, 6).Interior.ColorIndex = 38
Else
Cells(lRow, 5) = "Email sent"
Cells(lRow, 6) = Now()
End If
End If
End If
Next lRow
End Sub
Try to sSendTo = Range("D3").value, if it's not worked. Please process the sSendTo=Join(split(range("D3").value,";"),";")
I am trying to send an email with the below code from my workbook. It works fine but only until I try to attach a file.
The file is created by another VBA code and the file name is defined by the cell values specified below, but I get a debug error when I try to run the code and it won't attach. I've tested with a named path eg C:test\test.docx and it works fine.
How can I get it to accept the path based on the cell values? I've set it to .Display whilst testing rather than send.
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub SendEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim path As String
path = "\\Wbcphfil01.wbc.lan\dts\Groups\Operational_Services\opserv_group\Enforcement\NRSWA\Licences\Mobile Plant\Applications 2019-20\" & Cells(i, 4) & " (" & Cells(i, 13) & ").docx"
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 7)
If .Value <> "" And Cells(i, 5) = "Mobile Plant" Then
With objMail
.To = Cells(i, 11).Value
.Subject = "Your " & Cells(i, 5).Value & " licence - " & Cells(i, 4).Value
.Body = "abc"
.Attachments.Add path
.Display
End With
End If
End With
Next i
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
You are using Cells(i, 4) on the path to the file before you defined what the variable i actually is! Maybe move the path inside your For Loop?
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub SendEmail()
Dim objOutlook As Object
Dim objMail As Object
Dim OL As Outlook.Application, ES As Worksheet, r As Long, i As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim path As String
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
path = "\\Wbcphfil01.wbc.lan\dts\Groups\Operational_Services\opserv_group\Enforcement\NRSWA\Licences\Mobile Plant\Applications 2019-20\" & Cells(i, 4) & " (" & Cells(i, 13) & ").docx"
With Cells(i, 7)
If .Value <> "" And Cells(i, 5) = "Mobile Plant" Then
With objMail
.To = Cells(i, 11).Value
.Subject = "Your " & Cells(i, 5).Value & " licence - " & Cells(i, 4).Value
.Body = "abc"
.Attachments.Add path
.Display
End With
End If
End With
Next i
Set objOutlook = Nothing
Set objMail = Nothing
End Sub
New to VBA, attempting to list my outlook emails in excel given a specific time period. Found code to list my emails, but can't figure out how to restrict it to a time period, any ideas?
Sub GetMail()
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
'-------------------------------------------------------------
Application.ScreenUpdating = False
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
Set OLApp = CreateObject("Outlook.Application")
Set olFolder = OLApp.GetNamespace("MAPI").PickFolder
totalItems = olFolder.items.Count
mailCount = 0
For Each loopControl In olFolder.items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
mailCount = mailCount + 1
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
Set olMailItem = loopControl
With olMailItem
strTo = .To
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .Body
dateReceived = .ReceivedTime
strSubject = .Subject
End With
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
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
.Offset(0, 3).Value = strBody
End If
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
Set olMailItem = Nothing
End If
Next loopControl
Set olFolder = Nothing
Set OLApp = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
New to VBA, attempting to list my outlook emails in excel given a specific time period. Found code to list my emails, but can't figure out how to restrict it to a time period, any ideas?
Try This. Added 2 date variables date1 and date2. Adjust these as per your requirements.
Option Explicit
Sub GetMail()
Dim OLApp As Object
Dim olFolder As Object
Dim olMailItem As Object
Dim date1 As Date
Dim date2 As Date
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
'-------------------------------------------------------------
date2 = Now()
date1 = Now() - 3
Application.ScreenUpdating = False
Range("A1:F1").Value = Array("To", "From", "Subject", "Body", "Sent (from Sender)", "Received (by Recipient)")
Columns("E:F").EntireColumn.NumberFormat = "DD/MM/YYYY HH:MM:SS"
Set OLApp = CreateObject("Outlook.Application")
Set olFolder = OLApp.GetNamespace("MAPI").PickFolder
totalItems = olFolder.Items.Count
mailCount = 0
For Each loopControl In olFolder.Items
'//If loopControl is a mail item then continue
If TypeName(loopControl) = "MailItem" Then
mailCount = mailCount + 1
Application.StatusBar = "Reading email no. " & mailCount & " of " & totalItems
Set olMailItem = loopControl
With olMailItem
strTo = .To
If Left(strTo, 1) = "=" Then strTo = "'" & strTo
strFrom = .Sender
If InStr(1, strFrom, "#") < 1 Then strFrom = strFrom & " - < " & .SenderEmailAddress & " >"
dateSent = .body
dateReceived = .ReceivedTime
strSubject = .Subject
End With
If dateReceived <= date2 And dateReceived >= date1 Then
With Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Value = strTo
.Offset(0, 1).Value = strFrom
.Offset(0, 2).Value = strSubject
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
.Offset(0, 3).Value = strBody
End If
.Offset(0, 4).Value = dateSent
.Offset(0, 5).Value = dateReceived
End With
End If
Set olMailItem = Nothing
End If
Next loopControl
Set olFolder = Nothing
Set OLApp = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox mailCount & " messages copied successfully.", vbInformation, "Complete"
End Sub
this is my first time asking a question here, would really appreciate how i could remove the loop and run the macro line by line manually?
Sub Email()
Dim olApp As Object
Dim olMail As Object
Dim olRecip As Object
Dim iRow As Long
Dim Recip As String
Dim Subject As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
Do Until IsEmpty(Cells(iRow, 1))
Recip = Cells(iRow, 1).Value
Subject = Cells(iRow, 3).Value
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Display
.CC = ""
.Subject = ""
.HTMLbody = "<html><body><p>Dear " & Cells(iRow, 2).Value & "," & "<br>" & "<br>" & "summary " & Cells(iRow, 3).Value & " summary" & Cells(iRow, 4).Value & "summary" & "<br>" & "<br>" & "summary" & "<br>" & "<br>" & "conclusion" & .HTMLbody
olRecip.Resolve
.Display
End With
iRow = iRow + 1
Loop
Set olApp = Nothing
Exit Sub
End Sub
comment your code
Sub Email() Dim olApp As Object Dim olMail As Object Dim olRecip As Object Dim iRow As Long Dim Recip As String Dim Subject As String
iRow = 2
Set olApp = CreateObject("Outlook.Application")
'If column A has more the 1 email, will send/display email 1 at a time
'Do Until IsEmpty(Cells(iRow, 1))
Recip = Cells(iRow, 1).Value
Subject = Cells(iRow, 3).Value
Set olMail = olApp.CreateItem(0)
With olMail
Set olRecip = .Recipients.Add(Recip)
.Display
.CC = ""
.Subject = ""
.HTMLbody = "<html><body><p>Dear " & Cells(iRow, 2).Value & "," & "<br>" & "<br>" & "summary " & Cells(iRow, 3).Value & " summary" & Cells(iRow, 4).Value & "summary" & "<br>" & "<br>" & "summary" & "<br>" & "<br>" & "conclusion" & .HTMLbody
olRecip.Resolve
.Display
End With
iRow = iRow + 1
'Msgbox to show email was sent or failed
'Loop
Set olApp = Nothing
Exit Sub
End Sub '
Are you trying to debug? I guess what you want to do is to press F8 to step into the code.