I'm writting macro that finds an e-mail and replies to it. The problem is that the text I want to reply with does not add. Could you please tell me what I'm doing wrong?
Sub Test()
Dim olApp As Object
Dim olNs As Object
Dim Fldr As Object
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test")
i = 1
For Each olMail In olNs.Items
If InStr(olMail.Subject, "kanapka") <> 0 Then
With olMail.ReplyAll
.CC = "xyz#xyz"
.Body = "Dear All," _
& vbCrLf & "aaaaaa" 'these two lines should add
olMail.Reply.Display
End With
i = i + 1
End If
Next olMail
End Sub
Try adding this to your code:
For Each olMail In olNs.Items
If InStr(olMail.Subject, "testme") <> 0 Then
Set oReply = olMail.Reply
Set oRecip = oReply.Recipients.Add("x#y.z")
oRecip.Type = olCC
oReply.HTMLBody = "Thank you!!!" & oReply.HTMLBody
oReply.Display
Stop ' - remove this once you try the code.
End If
Next olMail
As you see, you have to declare oReply and oRecip as Objects, but these two make your life really easier.
In order to add some text to the answer, simply increment the body this way:
oReply.HTMLBody = "Thank you!!!" & oReply.HTMLBody
I have also included a Stop in your code, to make sure that it does not display plenty of emails.
Related
When I run the following code with .display, the Outlook Appointment gets created in the correct way (shared calendar, recipients, time etc) and I can send the resultant meeting request and it is received by the recipient as a meeting request. However, if I change .display to .send, everything appears to work OK, but the recipient recieves a meeting cancellation (for a meeting that doesn't exist!).
Can anyone point out where I'm going wrong?
Sub CreateMeetings()
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim oApp As Object
Dim oNameSpace As Namespace
Dim myCalendar As Object
Dim OLNS As Object
Const olAppointmentItem As Long = 1
Dim OLAppointment As Object
Dim MeetingKey As String
Dim datenum As Long
Dim smtprecipient As String
Dim MeetingKeyString As String
Dim emailchk As Long
Set oApp = New Outlook.Application
Set olApp = CreateObject("Outlook.Application")
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
'get default user email address
smtprecipient = GetSMTPEmailAddress
'check to see if email address returned is a valid one
emailchk = InStr(1, smtprecipient, "#company_domain.co.uk")
'get a valid email address if the check fails
If emailchk = 0 Then
smtprecipient = InputBox("Enter your Company Email Address", "Email Address Required")
End If
Set OLNS = olApp.GetNamespace("MAPI")
OLNS.Logon
Dim objRec As Outlook.Recipient
Set objRec = OLNS.CreateRecipient(smtprecipient)
objRec.Resolve
Set myCalendar = OLNS.GetSharedDefaultFolder(objRec, olFolderCalendar).Folders("Frontline")
Set OLAppointment = myCalendar.Items.Add(olAppointmentItem)
Dim i As Long, Schedsht As Worksheet
Set Schedsht = Worksheets("Shift Allocation")
Sheets("Shift Allocation").Select
For i = 6 To Range("A" & Rows.Count).End(xlUp).Row
If Schedsht.Range("T" & i).Value = "" And Schedsht.Range("S" & i).Value = True Then
datenum = Date + (Time * 10000) + i
MeetingKeyString = Schedsht.Range("Z" & i).Value
MeetingKey = "S" & CStr(datenum) & Schedsht.Range("B" & i).Value
With OLAppointment
.Subject = "Shift" & " (" & MeetingKey & ")"
.RequiredAttendees = Schedsht.Range("I" & i).Value & ";" & Schedsht.Range("J" & i).Value _
& ";" & Schedsht.Range("K" & i).Value
.Start = Schedsht.Range("D" & i).Value
.End = Schedsht.Range("E" & i).Value
.Location = Schedsht.Range("C" & i).Value
.ReminderMinutesBeforeStart = 720
.MeetingStatus = olMeeting
.Body = Schedsht.Range("M" & i).Value & vbCrLf & vbCrLf & "Welcome to our new Rota system. For details on how this all works, _
please go to xxxx."
.Display
'.Send
On Error GoTo 0
End With
Schedsht.Range("T" & i).Value = True
Schedsht.Range("Y" & i).Value = MeetingKey
Schedsht.Range("AA" & i).Value = MeetingKeyString
Else
End If
Next i
MsgBox "All Shifts Processed"
Set olAppItem = Nothing
Set olApp = Nothing
Set oFolder = Nothing
Exit Sub
Set olAppItem = Nothing
Set olApp = Nothing
Set oFolder = Nothing
End Sub
See above. changing to .display works OK, .send doesn't
You can not send items from a shared folder explicitly because an incorrect sender will be used. You can use the SentOnBehalfOfName property for mail items, but not appointments, when you need to send items on behalf of another person.
Call the Save method before the Send one to submit the item from a shared folder.
I send reports with Subject Name Like "Sales Report till 01-Sep-2022" in which only the date changes and initial like "Sales Report till*" remains the same.
Below is the code for "Replying to All" from sent items, which works well on "Replying to All" from sent items. The only problem is it's not replying on latest Sent Email.
It picks any email with "Sales Report till" whether that sent mail is from last week or last month.
I want to Reply to All on the latest Sent Email.
Sub OL_Email_Reply_To_All_WFN()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim objMail As Object
Dim objReplyToThisMail As MailItem
Dim lngCount As Long
Dim objConversation As Conversation
Dim objTable As Table
Dim objVar As Variant
Dim Path, WFN, SN As String
Dim WFN_Sub, WFN_RN, WFN_MB As String
Path = ThisWorkbook.Sheets("Main_Sheet").Range("B1") & "\" '''''Path to pick from "Main_Sheet" of ThisWorkbook
WFN = Path & ThisWorkbook.Sheets("Main_Sheet").Range("B2") ''''' Working File Name can be diffrent will change on sheet.
''''WFN_Sub = ThisWorkbook.Sheets("Main_Sheet").Range("B3")
''''WFN_RN = ThisWorkbook.Sheets("Main_Sheet").Range("B4")
''''WFN_MB = ThisWorkbook.Sheets("Main_Sheet").Range("B5")
''''WFN_SN = ThisWorkbook.Sheets("Main_Sheet").Range("B6")
'''''Original Subject Name looks like "Sales Report till 01-Sep-2022" in which date changes every everytime.
WFN_Sub = "Test Email" '''''Subject to find should be intial only
WFN_RN = "Hi Friend" '''''Recipient Name
WFN_MB = "Please ignore it's a Test Email" ''''''''''Mail Body
SN = "My Name" '''''''''Senders Name
Set olApp = Session.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)
lngCount = 1
ThisWorkbook.Activate
For Each objMail In Fldr.Items
If TypeName(objMail) = "MailItem" Then
If InStr(objMail.Subject, WFN_Sub) <> 0 Then
Set objConversation = objMail.GetConversation
Set objTable = objConversation.GetTable
objVar = objTable.GetArray(objTable.GetRowCount)
Set objReplyToThisMail = olApp.Session.GetItemFromID(objVar(UBound(objVar), 0))
With objReplyToThisMail.ReplyAll
.Subject = WFN_Sub & " " & Format(Now() - 1, "DD-MMM-YYYY")
.HTMLBody = WFN_RN & "<br> <br>" & WFN_MB & "<br> <br>" & "Kind Regards" & "<br>" & SN
.display
.Attachments.Add WFN
End With
Exit For
End If
End If
Next objMail
Set olApp = Nothing
Set olNs = Nothing
Set Fldr = Nothing
Set objMail = Nothing
Set objReplyToThisMail = Nothing
lngCount = Empty
Set objConversation = Nothing
Set objTable = Nothing
If IsArray(objVar) Then Erase objVar
End Sub
Before getting the last row in the table (retrieved from the conversation object) you need to sort items based on the recieved date:
'Sort by ReceivedTime in descending order
table.Sort "[ReceivedTime]", True
Only after that you may rely on the last item in the code.
There is possibly simpler code.
Option Explicit
Sub OL_Email_Reply_To_All_WFN()
' reference Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.Folder
Dim objMail As Object
Dim Path As String, WFN As String, SN As String
Dim WFN_Sub As String, WFN_RN As String, WFN_MB As String
'Path = ThisWorkbook.Sheets("Main_Sheet").Range("B1") & "\" '''''Path to pick from "Main_Sheet" of ThisWorkbook
'WFN = Path & ThisWorkbook.Sheets("Main_Sheet").Range("B2") ''''' Working File Name can be diffrent will change on sheet.
''''WFN_Sub = ThisWorkbook.Sheets("Main_Sheet").Range("B3")
''''WFN_RN = ThisWorkbook.Sheets("Main_Sheet").Range("B4")
''''WFN_MB = ThisWorkbook.Sheets("Main_Sheet").Range("B5")
''''WFN_SN = ThisWorkbook.Sheets("Main_Sheet").Range("B6")
'''''Original Subject Name looks like "Sales Report till 01-Sep-2022" in which date changes every everytime.
WFN_Sub = "Test Email" '''''Subject to find should be intial only
WFN_RN = "Hi Friend" '''''Recipient Name
WFN_MB = "Please ignore it's a Test Email" ''''''''''Mail Body
SN = "My Name" '''''''''Senders Name
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderSentMail)
Dim fldrItems As Outlook.Items
Set fldrItems = olFldr.Items
fldrItems.Sort "[ReceivedTime]", True
Dim i As Long
For i = 1 To fldrItems.Count
If TypeName(fldrItems(i)) = "MailItem" Then
If InStr(fldrItems(i).Subject, WFN_Sub) <> 0 Then
Debug.Print fldrItems(i).ReceivedTime
With fldrItems(i).ReplyAll
.Subject = WFN_Sub & " " & Format(Now() - 1, "DD-MMM-YYYY")
.htmlbody = WFN_RN & "<br> <br>" & WFN_MB & "<br> <br>" & "Kind Regards" & "<br>" & SN
.Display
'.Attachments.Add WFN
End With
Exit For
End If
End If
Next
Set olApp = Nothing
Set olNs = Nothing
Set olFldr = Nothing
Set fldrItems = Nothing
Set objMail = Nothing
End Sub
I created the below code to reply based on the email subject listed in Excel cells. It cannot loop through the cells.
It can only reply to one email and cannot continue to the next step.
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(olFolderToDo)
IsExecuted = False
i = 2
For Each olMail In Fldr.Items
If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then
With olMail.Reply
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
.Display
End With
i = i + 1
End If
Next olMail
End Sub
You change rows before checking all items.
You could move i = i + 1 after Next olMail but you would need additional code to complete the second loop.
Instead apply another For loop.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub Display()
' Early binding
' Set reference to Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.Folder
Dim olMail As Object
Dim i As Long
Dim lastRow As Long
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 olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)
' https://stackoverflow.com/questions/38882321/better-way-to-find-last-used-row
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Debug.Print
Debug.Print "lastRow:" & lastRow
For i = 2 To lastRow
Debug.Print
Debug.Print i & "- " & ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value
For Each olMail In Fldr.Items
Debug.Print " " & olMail.Subject
If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then
With olMail.Reply
.HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
Debug.Print "*** match ***"
.Display
End With
End If
Next olMail
Next
End Sub
Outlook folders may contain different kind of items. So, when you iterate over all items in the folder you may deal with different items - appointments, documents, notes and etc. To make sure that you deal with mail items only I'd recommend checking the MessageClass property of the item before accessing item-specific properties at runtime. Otherwise, an error will be raised and your loop will never come to the end.
The following code used to work but has suddenly started producing the above error message. It's designed to take contact details from each email in a folder, then send a new email out. I've run bug checks and yhe line that fails is:
Set objFolder = objFolder.Folders("Inbox").Folders("Test")
Here's the code:
Sub ListMailsInFolder()
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim Lines() As String
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder =
objFolder.Folders("Inbox").Folders("Test")
Worksheets("Sheet2").Cells.ClearContents
a = 1
For Each Item In objFolder.Items
If TypeName(Item) = "MailItem" Then
Item.Display
Worksheets("Sheet2").Cells(1, a).Value =
Item.Body
Item.Close 1
a = a + 1
Debug.Print Item.ConversationTopic
End If
Next
For x = 1 To 208
If Worksheets("Sheet2").Cells(1, x) = "" Then
Exit For
End If
Set OutApp = CreateObject("Outlook.Application")
Set objOutlookMsg = OutApp.CreateItem(olMailItem)
Set Recipients = objOutlookMsg.Recipients
Set objOutlookRecip =
Recipients.Add("<email removed for forum>")
objOutlookRecip.Type = 1
objOutlookMsg.SentOnBehalfOfName =
"<email removed for forum>"
objOutlookMsg.Subject = "Fleet Insurance"
objOutlookMsg.Body = "Testing this macro" & vbCrLf &
vbCrLf & "First Name: " & Worksheets("Sheet3").Cells(7, x) & vbCrLf & "Last Name: " & Worksheets("Sheet3").Cells(10, x) & vbCrLf & "Email Address: " & Worksheets("Sheet3").Cells(14, x)
'Fleet client relationship team in signature
'Resolve each Recipient's name.
For Each objOutlookRecip In objOutlookMsg.Recipients
objOutlookRecip.Resolve
Next
objOutlookMsg.Send
'objOutlookMsg.Display
Set OutApp = Nothing
Next x
End Sub
To reliably reference the default Inbox:
Option Explicit
Sub ListMailsInDefaultAccountFolder()
Dim objNS As Namespace
Dim objFolder As Folder
Dim defInboxFolder As Folder
Dim itmCount As Long
Dim i As Long
Set objNS = GetNamespace("MAPI")
Set defInboxFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = defInboxFolder.Folders("Test")
itmCount = objFolder.Items.Count
For i = 1 To itmCount
Debug.Print objFolder.Items(i).Subject
Next
End Sub
The error code is MAPI_E_NOT_FOUND. Make sure the folder named "Test" exist under Inbox.
The folders you are looking for, are most likely missing (not according to your Outlook, but according to your code). One reason this can happen is if your Inbox changes name, which it can do if you aren't using an English Outlook. Try this:
Set objFolder = objNS.Folders.GetFirst
For Each folder In objFolder.Folders
Debug.Print folder.Name
Next
It lists all folders where the Inbox should be. Hopefully you'll find something that you can identify as your Inbox. Replace that name in your code.
I'd like to build\edit the mail signiture in Excel:
1st cell : |Regards, |
2nd cell (Name) : |Asaf Gilad |
3rd Cell (Title): |PMO |
4th cell (Mail) : |Asaf#mail.com |
So that when I click send, the body of the message will look like:
Dear sir
................................
....... Message Content ........
................................
................................
Regards,
Asaf Gilad
PMO
Asaf#mail.com
The signiture contains pictures as well.
I managed to save the range as picture and send that picture as attachment, but the picture turned out to be empty in the body, dispite the fact that it was sent correctly as attachment.
Here is the code I use:
Public Sub ExportEmail(recipentName As String)
On Error GoTo err:
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olMail As Outlook.MailItem
Dim strEmailTo As String, strEmailCC As String, strEmailBCC As String
Dim FNAME As String
Dim oRange As Range
Dim oChart As Chart
Dim oImg As Picture
strEmailTo = ""
strEmailCC = ""
strEmailBCC = ""
strEmailTo = "a#a.com"
strEmailCC = "b#b.com
If strEmailTo "" Then
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = strEmailTo
olMail.CC = strEmailCC
olMail.BCC = strEmailBCC
olMail.Subject = " My Subject"
Set oRange = Sheets(1).Range("A1:Z100")
Set oChart = Charts.Add
oRange.CopyPicture xlScreen, xlPicture
oChart.Paste
FNAME = Environ$("temp") & "\testPic.gif"
oChart.Export Filename:=FNAME, FilterName:="GIF"
olMail.Attachments.Add FNAME
olMail.HTMLBody = "" & _
""
olMail.Attachments.Add FNAME
olMail.Send
End If
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Kill FNAME
Set olApp = Nothing
Set olNs = Nothing
Set oRange = Nothing
Set oChart = Nothing
Set oImg = Nothing
Exit Sub
err:
MsgBox err.Description
End Sub
This is a good question, Asaf. When I have built automated e-mail solutions, I've found it difficult to get the signature line in. It's possible, but not easy. Maybe it's updated in 2010, but I haven't checked yet.
What I do is place the entire body into a text file on a drive, complete with any html tags that I want for formatting. This gives me great flexibility in both making nicely formatted e-mails where I can assign variables as well.
I then access those files through the Microsoft Scripting Runtime library.
See below code snippets:
Option Explicit
Const strEmailBoiler As String = "\\server\path\folder\subfolder\email_text\"
Sub PrepMessage()
Dim strBody As String, strMon As String
strMon = range("Mon").Value
strFY = range("FY").Value
strBody = FileToString(strEmailBoiler, "reports_email_body.txt")
strBody = Replace(strBody, "[MONTH]", strMon)
strBody = Replace(strBody, "[YEAR]", Right(strFY, 2))
strBody = Replace(strBody, "[FILE PATH]", strFileName)
SendMail "firstname.lastname#xyz.com", "Subject Goes Here " & strMon & " YTD", strBody
End Sub
Function FileToString(ByVal strPath As String, ByVal strFile As String) As String
'requires reference to Microsoft Scripting Runtime Object Library (or late binding)
Dim ts As TextStream
Set fso = New FileSystemObject
Set ts = fso.OpenTextFile(strPath & strFile, ForReading, False, TristateUseDefault)
FileToString = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
End Function
Sub SendMail(strTo As String, strSubject As String, strHTMLBody As String, Optional strAttach As String, Optional strCC As String)
'requires reference to Microsoft Outlook X.X Object Library (or late binding)
Dim olApp As Outlook.Application
Dim olMI As Outlook.MailItem
Set olApp = CreateObject("Outlook.Application")
Set olMI = olApp.CreateItem(olMailItem)
With olMI
.To = strTo
.Subject = strSubject
.HTMLBody = strHTMLBody
If strAttach <> vbNullString Then .Attachments.Add strAttach
.Display 'using this because of security access to Outlook
'.Send
End With
End Sub
Then my reports_email_body.txt file will look like this:
<p>Hello Person,</p>
<p>The Reports file for [MONTH] FY[YEAR] has been saved in the following location:</p>
<p>[FILE PATH]</p>
<p>Best,</p>
<br>
Scott Holtzman
<br>My Address
<br>my title
<br>whatever else...
In Excel 2010 (and possibly 2007) you can add .HTMLBody to the end of your body string. For instance, use something like this:
.HTMLBody = "<br>" & strbody & .HTMLBody
' <br> is an HTML tag to turn the text into HTML
' strbody is your text from cell C9 on the mail tab
' .HTMLBody inserts your email signature
This will at least solve your signature line problem.
I am looking for a solution for the same problem: Inserting a range as a picture.