I have code that will search through a user's Outlook and reply to an email depending on the Subject phrase you input in the worksheet cell. I did have it working a couple days ago, but now I can not seem to get it to work (was deleted). Once run, an error message will continuously display for code line "Set olitems = flrd.Items", saying "Object variable or With block variable not set". I think the problem is the End if but wherever I place it either the code does nothing or the same error displays.
The only other problem with the working code (when it worked) was that it populated more than once. I wish it to populate only one time.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
On Error Resume Next
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
End if
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
Set Fldr = StoreInbox
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub
Firstly, get rid of the On Error Resume Next line.
Secondly, Fldr variable is never set. Did you mean to use storeInbox variable instead?
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
On Error Resume Next
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End if
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub
Related
I would like the message to be sent when there is a value in column H, for example "y" -> enter image description here
Sub sendCustEmails()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(oMailItem)
Dim strMailBody As String
intRow = 2
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
While (strISO <> "")
Set objEmail = objOutlook.CreateItem(oMailItem)
StrMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailBody = "<BODY style='font-size:11pt;font-family:Calibri(Body)'>" & ThisWorkbook.Sheets("Mail_Details").Range("B2").Text & "</BODY>"
strMailBody = Replace(strMailBody, Chr(10), "<br>")
strFolder = "C:\Users\CIOTTIC\OneDrive - IAEA\Desktop\AL TEST"
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
strSalutation = ThisWorkbook.Sheets("MS_Data").Range("C" & intRow).Text
strEmail = ThisWorkbook.Sheets("MS_Data").Range("D" & intRow).Text
strCC = ThisWorkbook.Sheets("MS_Data").Range("E" & intRow).Text
strFile = ThisWorkbook.Sheets("MS_Data").Range("F" & intRow).Text
strFile2 = ThisWorkbook.Sheets("MS_Data").Range("G" & intRow).Text
StrMailSubject = Replace(StrMailSubject, "<ISO>", strISO)
strMailBody = Replace(strMailBody, "<Salutation>", strSalutation)
With objEmail
.To = CStr(strEmail)
.CC = CStr(strCC)
.Subject = StrMailSubject
.BodyFormat = olFormatHTML
.Display
.Attachments.Add strFolder & "\" & strFile
.Attachments.Add strFolder & "\" & strFile2
.HTMLBody = strMailBody & .HTMLBody
.Send
End With
intRow = intRow + 1
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
Wend
MsgBox "Done"
End Sub
Thank you very much!
How about :
Sub Test()
If Range("A1").Value <> "" Then
GoTo SendEmail
Else: Exit Sub
End If
Send Email:
'Enter the rest of your code here.
End Sub
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub sendCustEmails_WithCondition()
' Late binding
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Dim strISO As String
Dim strMailSubject As String
Dim longRow As Long
longRow = 2
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
Debug.Print "strISO: " & strISO
While (strISO <> "")
If ThisWorkbook.Sheets("MS_Data").Range("H" & longRow).Text = "Y" Then
'Typo - use Option Explicit
'Set objEmail = objOutlook.CreateItem(oMailItem)
' For early binding oMailItem should be olMailItem
' This is "accepted" in late binding without Option Explicit.
' Appears the variable "oMailItem" which is empty is treated as a zero.
Set objEmail = objOutlook.CreateItem(0)
'strMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailSubject = "Subject is <ISO>"
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
strMailSubject = Replace(strMailSubject, "<ISO>", strISO)
Debug.Print " strMailSubject: " & strMailSubject
With objEmail
.Subject = strMailSubject
.Display
End With
Else
' Not Y
Debug.Print " No mail."
End If
longRow = longRow + 1
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
Debug.Print "strISO: " & strISO
Wend
MsgBox "Done"
End Sub
I generate an Outlook HTML formatted email to send to the email address designated by cell.
I attach multiple files located in the same folder as the workbook with the FileDialog box.
I would like the initial folder that comes up to be the location of the current workbook.
Private Sub CommandButton1_Click()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C14").Value
.Subject = Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " Tile Estimate"
.HTMLBody = Range("B14").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the" & Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click()
End Sub
Update, here is what I ended up using
Sub Email_1()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.Filters.Clear
xFileDlg.Filters.Add "pdf files", "*.pdf"
xFileDlg.AllowMultiSelect = True
xFileDlg.InitialFileName = ThisWorkbook.Path
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C13").Value
.Subject = Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " Tile Estimate"
.HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Range("B13").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the " & Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
I have working code that replies to an email in the user's Outlook, based on the subject. However I am not able to have the code search through all the user's inboxes.
As of now it will only search through the user's specific inbox. Here is my code, I have searched around but I can not find a solution that my knowledge of VBA can comprehend.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End Sub
You may reference any Inbox like this:
Option Explicit
Sub Inbox_by_Store()
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
Debug.Print j & " DisplayName - " & allStores(j).DisplayName
Set storeInbox = Nothing
' Some stores will not have an inbox
' Bypass possible expected error if there is no inbox in the store
On Error Resume Next
' Note this is one of the rare acceptable uses for On Error Resume Next
Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
' Turn off error bypass as soon as it is no longer needed
On Error GoTo 0
If Not storeInbox Is Nothing Then
storeInbox.Display
' your code here instead of storeInbox.Display
' Set Fldr = storeInbox
End If
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub
I don't really have the ability to test out whether this works, but these are the changes that I mentioned in the comments, I hope they work!
Sub Display()
'...
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Dim mySubfolder As Outlook.Folder 'added
For Each mySubfolder In Fldr.Folders 'added
Set olItems = mySubfolder.Items 'changed
For i = 1 To olItems.count
'...
Next i
Next mySubfolder 'added
End Sub
Sub Display()
Dim myMail As Outlook.MailItem
Dim myReply As Outlook.MailItem
Dim numItems As Integer
Dim mySelected As Selection
Dim i As Integer
Dim myText As String
Dim signature As String
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set mySelected = Outlook.ActiveExplorer.Selection
numItems = mySelected.Count
For i = 1 To numItems
Set myMail = mySelected(1)
Set myReply = myMail.Reply
myText = myMail.Body
myReply.Subject = "RO Finalized WF: Annual Review. Entity"
myText = "Hi All," & vbCrLf & vbCrLf & "Worflow ID:" & vbCrLf & vbCrLf & "infoinfoinfoinfo" & vbCrLf & vbCrLf & "Thanks," & vbCrLf & "Josh" & signature
myReply.HTMLBody = myText & vbCrLf & vbCrLf & myMail.HTMLBody
Myreply.display
Set myMail = Nothing
Set myReply = Nothing
Next
Set mySelected = Nothing
End Sub
The code above displays a reply to the email you currently have open in Outlook including who sent it (placed in To:) with the whole body of the email you currently have open in Outlook.
This is what I want it to do except instead of replying to the open email, I want it to reply to the email specifically by it's subject. Also I want it to include exactly what all replies include in Outlook (the line separating each email, with the From:, Sent,: To:, CC:, Subject: of the previous email showing). Also vbCrLf is not doing it's purpose after MyText.
I would also like it to place the CC: from the previous email in the CC of the email I am creating.
I am not an expert in VBA and have tried as much as I could think of.
Thank you for the help in advance :)
I have found another option and the code is displayed below.
This will populate a reply email, with everything I need except my customized body.
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
IsExecuted = False
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "checklist") <> 0 Then
If Not IsExecuted Then
With olMail.ReplyAll
.HTMLBody = "Dear All," & "<br>" & signature
End With
IsExecuted = True
olmail.ReplyAll.Display
End If
End If
Next olMail
End Sub
Solution
Sub Display()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
IsExecuted = False
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "Subject") <> 0 Then
If Not IsExecuted Then
With olMail.ReplyAll
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & signature & .HTMLBody
.Display
End With
IsExecuted = True
End If
End If
Next olMail
End Sub
I will receive the Journal entries from the client and need to reply to the same mail.
I have tried the below code to execute reply to chain of mails. But the code is returning the all mails which contains the same subject line.
I need to reply which comes recently. I have tried many solutions, but I unable to fix it.
How do I Reply to an email based on subject, received time and date
Sub mail()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr
For Each olMail In olFldr.Items
If InStr(olMail.Subject, Range("C2")) <> 0 Then
Set ReplyAll = olMail.ReplyAll
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Veronica <br><br>" & _
"The " & _
Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1) & "</B> has been posted.<br>" & _
"<br><br>Regards," & _
"<br><br>Rajesh</font>" & .HTMLBody
emailReady = True
.Display
End With
End If
Next olMail
If Not emailReady Then
i = i + 1
If i > Fldr.Folders.Count Then
MsgBox ("The email with the given subject line was not found!")
Exit Sub
Else
Set olFldr = Fldr.Folders(i)
GoTo tryAgain
End If
End If
End Sub
Work with Items.Restrict Method (Outlook) to Filter by Subject and Date & Time
Make sure to convert your subject Range("C2") to string variable then use it on your filter
Example
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Subject As String
Subject = ThisWorkbook.Sheets("Sheet1").Range("C2").Text
Debug.Print Subject
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '02/20/2018' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '02/25/2018' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is mailitem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
End If
Next
End Sub
Items.Restrict Method Applies a filter to the Items collection, returning a new collection containing all of the items from the original that match the filter.
Edit - Complete Code
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Subject As String
Subject = ThisWorkbook.Sheets("Sheet1").Range("C2").Text
Debug.Print Subject
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '03/07/2018' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '03/25/2018' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
With ReplyAll
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Veronica <br><br>" & _
"The " & Left(ActiveWorkbook.name, _
InStr(ActiveWorkbook.name, ".") - 1) & _
"</B> has been posted.<br>" & _
"<br><br>Regards," & _
"<br><br>Rajesh</font>" & .HTMLBody
.Display
End With
End If
Next
End Sub
https://stackoverflow.com/a/43622710/4539709