I am trying to "replytoall" with a given format in the Body.
I use the following code to search for and display the mails.
Sub Test()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "Application for Privilege Leave - Leave ID - Dev-PL-45252-4") <> 0 Then
olMail.Display
i = i + 1
End If
Next olMail
End Sub
I need to Replyall with the same subject and a prescribed body and signature.
It is similar to when we open up a mail in Outlook and click on the Reply to All button.
I want it triggered from Excel.
Since you are using Early Binding, Change
Dim olMail As Variant
to
Dim olMail As Outlook.MailItem
And then you will be able to access all the properties of the olMail item. One of which is .ReplyAll
ScreenShot
If InStr(olMail.Subject, "Blah Blah") <> 0 Then
olMail.Display
olMail.ReplyAll
DoEvents
'
'~~> Rest of the code
'
i = i + 1
End If
There is a ReplyAll method which returns a mail object. See here.
So if you are iterating through some mails, then this should work:
For Each oMail in Fldr.Items
If InStr(olMail.Subject, "mysubject") <> 0 Then
With oMail.ReplyAll
.Subject = oMail.Subject '~~> this is optional
.Body = "your Body"
'~~> all other stuff you need your mail to have
.Display '~~> change to .Send if it is already ok
End With
End If
Next
Not tested but should be close.
Try this one:
olMail.ReplyAll
olMail.ReplyAll.body = bodyMail & vbLF & .body
Related
I have a script that searches a group inbox subfolder and replies to the first email with a matching subject. It then replies to all. When I populate the email I cannot add my text to the rest of the email. Only either or.
I've seen many responses to similar problems that show .HTMLBody = "test" & .HTMLBody as a solution but when the debug reaches this line, the second .HTMLBody is shown as 'application-defined or object-defined error'.
Any insight into whats causing the problem or where else I can get the info from previous emails in the chain to input it that way would be greatly appreciated.
Thanks,
Sub Find_Email()
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim olNS As Namespace
Dim olMailbox As Folder
Dim olFolder As Folder
Dim subFolder As Folder
Dim BodyText As String
Set olNS = GetNamespace("MAPI")
Set olMailbox = olNS.Folders("Group_Inbox")
Set olFolder = olMailbox.Folders("test_Folder")
Set subFolder = olFolder.Folders("test_subFolder")
Set olItems = subFolder.Items
TheDate = Format(Date, "DD-MM-YYYY")
TheDate1 = Format(Date, "YYYY-MM")
TheDate2 = Format(Date, "YYYYMMDD")
TheDate3 = Format(Date, "YYYY")
'Find most recent email and populate
olItems.Sort "ReceivedTime", True
For i = 1 To olItems.Count
Set olMail = olItems(i)
If InStr(olMail.Subject, "Desired_Subject " & TheDate) > 0 Then
Set olReply = olMail.ReplyAll
With olReply
.Display
.To = "Recipients#gmail.com"
.CC = ""
.Subject = "Test_Subject"
'.Attachments.Add "Document_destination"
.BodyFormat = olFormatHTML
.HTMLBody = "This is a test email sending in Excel" & .HTMLBody ' This is the problem line.
Exit Sub
End With
End If
Next i
End Sub
'I understand that it might be the fact it is in a group inbox, which means that it could work for you but 'still may not work for me.
'Thanks again,
Try this (i can't test it, just a thought )
'Somewehere declare this string variable
Dim incomingHTMLBody as string
olItems.Sort "ReceivedTime", True
For i = 1 To olItems.Count
Set olMail = olItems(i)
If InStr(olMail.Subject, "Desired_Subject " & TheDate) > 0 Then
incomingHTMLBody = olMail.HTMLBody
Set olReply = olMail.ReplyAll
With olReply
.Display
.To = "Recipients#gmail.com"
.CC = ""
.Subject = "Test_Subject"
'.Attachments.Add "Document_destination"
.BodyFormat = olFormatHTML
.HTMLBody = "This is a test email sending in Excel" & incomingHTMLBody
Exit Sub
End With
End If
Next i
End Sub
You may need a bit more care referencing Outlook objects in your environment.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Find_Email()
Dim objApp As Outlook.Application
Set objApp = CreateObject("outlook.application")
Dim objNS As Namespace
Set objNS = objApp.GetNamespace("MAPI")
Dim objMailbox As Outlook.Folder
Set objMailbox = objNS.Folders("Group_Inbox")
Dim objFolder As Outlook.Folder
Set objFolder = objMailbox.Folders("test_Folder")
Dim subFolder As Outlook.Folder
Set subFolder = objFolder.Folders("test_subFolder")
Dim objItems As Outlook.Items
Set objItems = subFolder.Items
Dim TheDate As Date
TheDate = Format(Date, "DD-MM-YYYY")
'Find most recent email and populate
objItems.Sort "ReceivedTime", True
Dim i As Long
Dim objMail As Outlook.MailItem ' olMail is not a good variable name
Dim objReply As Outlook.MailItem
Debug.Print objItems.Count
For i = 1 To objItems.Count
Debug.Print objItems(i).Subject
If objItems(i).Class = olMail Then ' verify item is a mailitem
Set objMail = objItems(i)
If InStr(objMail.Subject, "Desired_Subject " & TheDate) > 0 Then
Set objReply = objMail.ReplyAll
With objReply
.Display
.To = "Recipients#gmail.com"
.CC = ""
.Subject = "Test_Subject"
'.Attachments.Add "Document_destination"
.BodyFormat = olFormatHTML
Debug.Print .htmlbody ' verify property is available
.htmlbody = "This is a test email sending in Excel" & .htmlbody ' This is the problem line.
Exit For
End With
End If
End If
Next i
End Sub
I have code that sends emails using the default Outlook account.
I tried changing the code to send from a specific email. When I run the macro, nothing happens.
Is something wrong with the code, or is it not working due to another issue (with Outlook and the accounts/permissions associated with it)?
Sub CommandButton1_Click()
Dim wb As Workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim q As Long
Dim oAccount As Outlook.Account
Set wb = ThisWorkbook
For Each oAccount In Outlook.Application.Session.Accounts
If oAccount = "theEmailiWantToUse#domain.com" Then
For q = 2 To 3 'LastRow
eName = wb.Sheets(1).Cells(q, 2).Value
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
mailBody = "Hello, "
With olMail
.To = Worksheets("Emails").Cells(q, 4).Value
.Subject = eName
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 14px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
Set .SendUsingAccount = oAccount
.Display
' .Send
End With
Next
Else
End If
Next
Set olMail = Nothing
Set olApp = Nothing
End Sub
I know I have access to the email I would like to send emails from, as I can select it from Outlook and it works.
Add this line within the olMail
.SentOnBehalfOfName = "youraddress" 'here change this
please use this routine to find Account number of sender .
Sub Which_Account_Number()
'Don't forget to set a reference to Outlook in the VBA editor
Dim OutApp As Outlook.Application
Dim I As Long
Set OutApp = CreateObject("Outlook.Application")
For I = 1 To OutApp.Session.Accounts.Count
MsgBox OutApp.Session.Accounts.Item(I) & " : This is account number " & I
Next I
End Sub
Then
.SendUsingAccount = olApp.Session.Accounts.Item(5)' whatever account index number you want to send. i have chosen 5
instead of
Set .SendUsingAccount = oAccount
This method works for me . You can further integrate this concept in your programme. Please ensure Reference to Outlook Object Library is set in Tools/References.
I need to search for mail in Sent Items, sent on current date and with subject as "Task Completed". Sometimes Subject may have additional text like Task Completed on 07/01/2017 or Task Completed 01/09/2017.
I found this Outlook VBA code, which displays found mail. I want the code to run in Excel with wildcard search options and open an Excel file.
I tried to search the subject with wildcard "*", like "Task Completed*" and "Task Completed on & Format(Date, "dd/mm/yyyy")" for which I got an syntax error/compile error
Sub Test()
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr 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(olFolderSentMail)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "Task Completed on 07/01/2017") <> 0 Then
olMail.Display
i = i + 1
End If
Next olMail
End Sub
I am using Office 2010.
In order to loop through all items in Sent Items folder, including Calendar events you may have, use the Dim olMail As Object (instead of AS Outlook.MailItem).
To look for "Task Completed" string somewhere in the email's title, use If olMail.Subject Like "*Task Completed*" Then (adding the wildcard * before and after the searched string).
I've added 2 lines of code, that output all matching emails to your worksheet in Column A and Column B.
Code
Option Explicit
Sub Test()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Object
Dim i As Integer, j As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)
i = 1
For Each olMail In Fldr.Items
' check if mail subject contains "Task Completed" in the email title
If olMail.Subject Like "*Task Completed*" Then
'Range("A" & i).Value = olMail.Subject ' <-- output email name to column A
'Range("B" & i).Value = olMail.SentOn ' <-- output email sent date to column B
olMail.Display ' show email through Excel
i = i + 1
End If
Next olMail
End Sub
I am using the following VBA code which checks for any emails with a specific subject heading.
The problem is it checks my default outlook inbox folder when I need it to check the inbox of my other email account.
Can someone please show me how I would do this?
Sub Macro1()
Set olApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim I As Long
Dim olMail As Variant
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""New Supplier Request: Ticket""")
If Not (olMail Is Nothing) Then
For Each myItem In myTasks
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
If InStr(myAttachment.DisplayName, ".txt") Then
I = I + 1
myAttachment.SaveAsFile "\\uksh000-file06\Purchasing\NS\Unactioned\" & myAttachment
End If
Next
End If
Next
For Each myItem In myTasks
myItem.Delete
Next
Call Macro2
Else
MsgBox "There Are No New Supplier Requests."
End If
End Sub
Instead of iterating through all folder items in Outlook:
For Each myItem In myTasks
If myItem.Attachments.Count <> 0 Then
For Each myAttachment In myItem.Attachments
I'd suggest using the Find/FindNext or Restrict methods of the Items class. Also you may consider using using the AdvancedSearch method of the Application class. Take a look at the following articles for the sample code which illustrates how to use them in the code:
How To: Use Restrict method to retrieve Outlook mail items from a folder
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
Advanced search in Outlook programmatically: C#, VB.NET
The reason is that you have declared variable myItem as Outlook.MailItem and you use it later to iterate through the collection of items in MAPI folder.
However, MAPI folder contains not only MailItems but also MeetingItems and every time the loop finds an object of MeetingItem type, it throws an Mismatch type error since it expects only objects of MailItem type.
You just need to change declaration of myItem variable to:
Dim myItem as Object
=============================================================
The code below should iterate through the filtered items only:
Sub Work_with_Outlook()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim myItem As Object
Dim myAttachment As Outlook.Attachment
Dim olMail As Variant
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""test""")
While Not olMail Is Nothing
If olMail.Attachments.Count Then
For Each myAttachment In olMail.Attachments
i = i + 1
myAttachment.SaveAsFile "\\uksh000-file06\Purchasing\Supplier Attachments\test" & i & ".txt"
Next myAttachment
End If
Set olMail = myTasks.FindNext
Wend
MsgBox "Scan Complete."
End Sub
Need to save excel attachments in Outlook emails from oldest email to newest email and mark email as read. The newer attachments will overwrite the older if there is more than one unread email.
I receive an number of emails daily that need to be saved to run a report. However, if one report is missed, it is ignored and I go to the next dataset. The following works but does not always save the oldest first...it jumps around.
I have tried a number of options to save oldest first, with no luck. Any help on how I could make this consistently take the oldest email first. Thanks
Sub Save_Attachments()
Dim olApp As Outlook.Application, olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim olAttachment As Outlook.Attachment, lngAttachmentCounter As Long
Dim i As String
On Error GoTo Oooops
Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("sub_folder")
If olFolder Is Nothing Then Exit Sub
For Each olMail In olFolder.Items
If olMail.UnRead = True Then
For Each olAttachment In olMail.Attachments
lngAttachmentCounter = lngAttachmentCounter + 1
olAttachment.SaveAsFile ThisWorkbook.Path & "\zzzzz.xls"
Next olAttachment
End If
If olMail.UnRead Then
olMail.UnRead = False
End If
Next olMail
Exit Sub
Oooops:
MsgBox Err.Description, vbExclamation, "An error occurred"
End Sub
Since you did not state the options you tried maybe you did not try
For j = olFolder.Items.count To 1 Step -1
Something like this.
Option Explicit
Sub Save_Attachments_ReverseOrder()
Dim olApp As Outlook.Application, olNameSpace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olMail As Object ' <-- olMail is not necessarily a mailitem
Dim olAttachment As Outlook.attachment, lngAttachmentCounter As Long
Dim j As Long
On Error GoTo Oooops
Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("sub_folder")
If olFolder Is Nothing Then Exit Sub
For j = olFolder.Items.count To 1 Step -1
Set olMail = olFolder.Items(j)
If TypeOf olMail Is mailitem Then
If olMail.UnRead = True Then
Debug.Print olMail.subject & " - " & olMail.ReceivedTime
'For Each olAttachment In olMail.Attachments
' lngAttachmentCounter = lngAttachmentCounter + 1
' olAttachment.SaveAsFile ThisWorkbook.Path & "\zzzzz.xls"
'Next olAttachment
olMail.UnRead = False
Else
Debug.Print vbCr & olMail.subject & " - " & olMail.ReceivedTime & " was previously read"
End If
Else
Debug.Print vbCr & "Current item is not a mailitem."
End If
Next j
Exit Sub
Oooops:
MsgBox Err.Description, vbExclamation, "An error occurred"
End Sub