I have written a working code to reply to an email in certain format, however the result is missing some info for the last received email in the Html body (From, sent, to, cc, subject. I'm not even sure if this is called the mail header).
If I click on the Outlook 2013 default 'reply' button, these info would have been auto-generated ahead of the last email, while above it would then be my reply content.
So which function should I use to call these info out? The info must appear in all my replies, so I need to figure it out one way or the other. My code:
'there is a getsignature function before the code.
Public Sub my_reply()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSelection As Outlook.Selection
Dim objMail As Outlook.mailitem
Dim StrSignature As String
StrSignature = GetSignature("C:\Users\xxx\xxx\Microsoft\Signatures\ABC.htm")
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
If objMsg.Class = olMail Then
objMsg.Categories = "Category A"
Set myreply = objMsg.Reply
myreply.To = objMsg.SenderEmailAddress
myreply.BCC = "xxx#abc" & " ; " & "xxx#abc"
myreply.Subject = "XYZ matter" & objMsg.Subject
myreply.Display
myreply.HTMLBody = StrSignature & "<br><br>" & objMsg.HTMLBody
Release:
Set objMsg = Nothing
Set oExplorer = Nothing
End If
Next
End Sub
ReplyAll should get the cc. If you are only concerned about missing text ignore this.
Set myReply = objMsg.ReplyAll
You are overwriting the initial myreply.HTMLBody with objMsg.HTMLBody
myreply.HTMLBody = StrSignature & "<br><br>" & objMsg.HTMLBody
Instead append to the initial myreply.HTMLBody
Option Explicit
Public Sub my_replyAll()
'Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSelection As Selection
'Dim objMail As Outlook.mailitem
Dim myReply As mailitem
Dim StrSignature As String
StrSignature = GetSignature("C:\Users\xxx\xxx\Microsoft\Signatures\ABC.htm")
' Set objOL = CreateObject("Outlook.Application")
'Set objSelection = objOL.ActiveExplorer.Selection
Set objSelection = ActiveExplorer.Selection
For Each objMsg In objSelection
If objMsg.Class = olMail Then
Set myReply = objMsg.ReplyAll
myReply.To = objMsg.SenderEmailAddress
myReply.BCC = "xxx#abc" & " ; " & "xxx#abc"
myReply.Subject = "XYZ matter " & objMsg.Subject
myReply.Display
'myReply.HtmlBody = StrSignature & "<br><br>" & objMsg.HtmlBody
myReply.HtmlBody = StrSignature & "<br><br>" & myReply.HtmlBody
Release:
Set objMsg = Nothing
End If
Next
End Sub
Related
Below code saves all items in an outlook folder to my desktop as PDFs. One flaw, The heading of the last email in the string is cut off. So when i send out vottingOptions, the PDF comes up blank for the response. Any ideas? Thank you.
Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object
Dim psName As String, pdfName As String
Set outApp = CreateObject("Outlook.Application")
Set objOutlook = outApp.GetNamespace("MAPI")
Set objFolder = objOutlook.GetDefaultFolder(olFolderInbox).Folders("PDF Conversion")
Set myItems = objFolder.Items
FolderPath = "C:\Users\E086365\Desktop\Suz Macros\PDF Emails\"
Dim objDoc As Object, objInspector As Object
For Each myItem In myItems
FileName = Replace(myItem.SenderName, ":", "") & " - " & Replace(myItem.Subject, ":", "") & " - " & Replace(Replace(myItem.ReceivedTime, ":", ""), "/", "-")
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
Next myItem
End Sub```
First of all, there is no need to create a new Outlook Application instance if the code is run in Outlook. Instead, use the built-in Application property:
Set objOutlook = Application.GetNamespace("MAPI")
In the code, I also recommend checking the file path string after all replacing operations run against values:
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "a22550#stuart.iit.edu"
.Subject = "Report of Fixed Income" & Format(Now() - 1, "mmmm dd,yyyy")
.Body = "Dear Sir" & vbNewLine & Format(Now() - 1, "mmmm dd,yyyy") &
"Please regard the following tables:" & vbNewLine &
"Thank you!"
.Attachments.Add "C:\Users\008425\Desktop\Fixed Income--2020.05.13.xlsm
'word Editor
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = objMail.GetInspector.WordEditor
wdDoc.Application.Selection.Start = Len(.Body)
I tried to Copy my excel range to Outlook mail with the my greeting description in the beginning and come next my excel copy range as a picture...After I run this syntax, my greeting skip to the end of the mail body just like signature..
Does anyone know hot to set sequences greetings→ paste charts→signatures from start to end in the outlook mail body by VBA?
[ wdDoc.Application.Selection.Start = Len(.Body)] is not right
Private Sub test()
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim defSignature As String
With objMail
.Display ' Bring the signature to the body
defSignature = objMail.Body ' Save the signature
' Replace the body
.Body = "Dear Sir" & vbNewLine & Format(Now() - 1, "mmmm dd,yyyy") & _
"Please regard the following tables:" & vbNewLine & vbNewLine
'.Attachments.Add "C:\Users\008425\Desktop\Fixed Income--2020.05.13.xlsm"
'word Editor
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = objMail.GetInspector.WordEditor
' Move the cursor to the end of the body
wdDoc.Application.Selection.EndKey Unit:=wdStory, Extend:=wdMove
' Insert after the cursor
wdDoc.Application.Selection.InsertAfter "This should be inserted after current body."
objMail.Body = objMail.Body & vbNewLine & "Thank you!" & defSignature
End With
End Sub
So far I have been able to attach the file programmatically with this:
Private Sub AttachmentFile()
Dim oLook As Object
Dim oMail As Object
Dim FD As Object
Dim vrtSelectedItem As Variant
Set oLook = CreateObject("Outlook.Application")
Set oMail = oLook.CreateItem(0)
Set FD = Excel.Application.FileDialog(3)
With oMail
FD.AllowMultiSelect = True
FD.Filters.Clear
FD.Filters.Add "All Files", "*.*"
FD.InitialFileName = "\\ad\dfs\Shared Data\"
If FD.Show = True Then
For Each vrtSelectedItem In FD.SelectedItems
.Attachments.Add vrtSelectedItem
Next
End If
.Display
End With
Set FD = Nothing
Set oMail = Nothing
Set oLook = Nothing
End Sub
Now that the email is created and I can select the file from a specified folder, I am trying to have the change the mail item's subject to the name of the attached file, also replacing the _ (underscore) with a | (pipe symbol).
Here is the now Working code I have. I also added a signature to the email with correct fonts and image of my default signature in outlook.
Private Sub SubNBodyNTo()
Dim myInspector As Outlook.Inspector
Dim MItem As MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set MItem = myInspector.CurrentItem
Set myAttachments = MItem.Attachments
MItem.Subject = myAttachments.Item(1).DisplayName
MItem.Subject = Replace(MItem.Subject, "_", " | ")
MItem..HTMLBody = MItem.Subject & " Is attached for your approval." & "<br>" & MItem.HTMLBody
MItem.To = "person#email.com"
MItem.CC = "OtherPeople#email.com"
End If
End If
End Sub
Private Sub SubNBodyNTo()
Dim myInspector As Outlook.Inspector
Dim MItem As MailItem
Dim myAttachments As Outlook.Attachments
Set myInspector = Application.ActiveInspector
If Not TypeName(myInspector) = "Nothing" Then
If TypeName(myInspector.CurrentItem) = "MailItem" Then
Set MItem = myInspector.CurrentItem
Set myAttachments = MItem.Attachments
MItem.Subject = myAttachments.Item(1).DisplayName
MItem.Subject = Replace(MItem.Subject, "_", " | ")
MItem..HTMLBody = MItem.Subject & " Is attached for your approval."
& "<br>" & MItem.HTMLBody
MItem.To = "person#email.com"
MItem.CC = "OtherPeople#email.com"
End If
End If
End Sub
I have this VBA code that allows to add contact from an Outlook selected folder or selected messages :
' The AddAddressesToContacts procedure can go in any Module
' Select the mail folder and any items to add to contacts, then run the macro
Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts= oNS.GetDefaultFolder(olFolderContacts)
Set colItems= folContacts.Items
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact= Nothing
bContinue= True
sSenderName= ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = oMail.Subject
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
.Save
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
I would like to go to the next address if the current address exists into the address book.
For the moment, I have this code :
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
But how to ignore the address already recorded in the address book ?
To go to the next address if the current address exists in the address book.
If Not (oContact Is Nothing) Then
bContinue = False
End If
I want to extract properties, like phone number, society, email,... from an e-mail which is in my inbox.
Set oOutlookmail = CreateObject("Outlook.Application")
Set oMyInspectors = oOutlookmail.Inspectors
Set oMail = oMyInspectors.Item(lCount2).CurrentItem
gsDate = Left(oMail.ReceivedTime, InStr(1, oMail.ReceivedTime, " ") - 1)
I can have the date but that's all. I looked with Contact item, we can add contact properties but not get the ones of a mail.
An other solution is to add to contacts the sender and delete it after but I didn't find how to do that.
Phone and other information is not stored in a sender address.
Re: "An other solution is to add to contacts the sender ..."
The limited amount of information available when creating a contact from scratch is described here http://www.slipstick.com/developer/create-contacts-from-messages/.
This macro is compliments of Outlook MVP and developer Ken Slovak from http://www.slovaktech.com
Public Sub AddAddressesToContacts()
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts= oNS.GetDefaultFolder(olFolderContacts)
Set colItems= folContacts.Items
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact= Nothing
bContinue= True
sSenderName= ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
If Not (oContact Is Nothing) Then
response = MsgBox("This appears to be an existing contact: " & sSenderName & ". Do you still want to add it as a new contact?", vbQuestion + vbYesNo, "Contact Adder")
If response = vbNo Then
bContinue = False
End If
End If
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Body = oMail.Subject
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
.Save
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
and here https://msdn.microsoft.com/en-us/library/office/ff869056.aspx