.Body of Mailitem is not returning anything
I am using the entryID to get access to the inbound email and set the object using Application.Session.GetItemFromID
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
Once I set olitem
Set olitem = Application.Session.GetItemFromID(strID)
it shows the email has been accessed, but when sText = olitem.Body is run stext ends up empty.
Here is the entire code that is fired from an Outlook Rule.
Sub ParseEPDMRequest(olitem As Outlook.MailItem)
Dim arr() As String
Dim ECONum As String
Dim ReqID As String
Dim sText As String
Dim strID As String
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
sText = olitem.Body
arr = Split(olitem.Body, ":")
arr = Split(arr(15), " ")
ECONum = GetECONum(arr(8))
sText = olitem.Subject
ReqID = GetReqId(sText)
Call TEAMtoEPDMPush(ECONum & ".xml", ReqID)
End Sub
Under certain circumstances the message can have no plain text body. You have to check the format of the body (see BodyFormat property):
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
If olitem.BodyFormat=OlBodyFormat.olFormatPlain Then
sText = olitem.Body
...
ElseIf olitem.BodyFormat=OlBodyFormat.olFormatHTML Then
...
Related
I found code in How to get the sender’s email address from one or more emails in Outlook?.
I need to get the e-mail addresses of the CC field as well.
Sub GetSmtpAddressOfSelectionEmail()
Dim xExplorer As Explorer
Dim xSelection As Selection
Dim xItem As Object
Dim xMail As MailItem
Dim xAddress As String
Dim xFldObj As Object
Dim FilePath As String
Dim xFSO As Scripting.FileSystemObject
On Error Resume Next
Set xExplorer = Application.ActiveExplorer
Set xSelection = xExplorer.Selection
For Each xItem In xSelection
If xItem.Class = olMail Then
Set xMail = xItem
xAddress = xAddress & VBA.vbCrLf & " " & GetSmtpAddress(xMail)
End If
Next
If MsgBox("Sender SMTP Address is: " & xAddress & vbCrLf & vbCrLf & "Do you want to export the address list to a txt file? ", vbYesNo, "Kutools for Outlook") = vbYes Then
Set xFldObj = CreateObject("Shell.Application").BrowseforFolder(0, "Select a Folder", 0, 16)
Set xFSO = New Scripting.FileSystemObject
If xFldObj Is Nothing Then Exit Sub
FilePath = xFldObj.Items.Item.Path & "\Address.txt"
Close #1
Open FilePath For Output As #1
Print #1, "Sender SMTP Address is: " & xAddress
Close #1
Set xFSO = Nothing
Set xFldObj = Nothing
MsgBox "Address list has been exported to：" & FilePath, vbOKOnly + vbInformation, "Kutools for Outlook"
End If
End Sub
Function GetSmtpAddress(Mail As MailItem)
Dim xNameSpace As Outlook.NameSpace
Dim xEntryID As String
Dim xAddressEntry As AddressEntry
Dim PR_SENT_REPRESENTING_ENTRYID As String
Dim PR_SMTP_ADDRESS As String
Dim xExchangeUser As exchangeUser
On Error Resume Next
GetSmtpAddress = ""
Set xNameSpace = Application.Session
If Mail.sender.Type <> "EX" Then
GetSmtpAddress = Mail.sender.Address
Else
PR_SENT_REPRESENTING_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x00410102"
xEntryID = Mail.PropertyAccessor.BinaryToString(Mail.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_ENTRYID))
Set xAddressEntry = xNameSpace.GetAddressEntryFromID(xEntryID)
If xAddressEntry Is Nothing Then Exit Function
If xAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or xAddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
Set xExchangeUser = xAddressEntry.GetExchangeUser()
If xExchangeUser Is Nothing Then Exit Function
GetSmtpAddress = xExchangeUser.PrimarySmtpAddress
Else
PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
GetSmtpAddress = xAddressEntry.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
End If
End If
End Function
How could I adapt the code to include the e-mail addresses from the CC field as well?
I tried setting Recipients but couldn't get the desired outcome.
You need to replace the GetSmtpAddress function with your own where you could get the CC recipients in the following way (a raw sketch):
Function GetSmtpAddress(Mail As MailItem) as String
Dim emailAddress as String
Dim recipient as Outlook.Recipient
Dim recipients as Outlook.Recipients
Set recipients = Mail.Recipients
For Each recipient In recipients
If recipient.Type = olCC Then
If recipient.AddressEntry.Type = "EX" Then
emailAddress = emailAddress & " " & recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
Else
emailAddress = emailAddress & " " & recipient.Address
End If
End If
Next
Return emailAddress
End Function
You may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.
Loop through all recipients in the MailItem.Recipients collection, check that Recipient.Type = olCC. For each Recipient object use Recipient.Address. Note that you can end up with EX type addresses (instead of SMTP). Check that Recipient.AddressEntry.Type is "SMTP". If it is not, use Recipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress instead (do check for nulls).
I've written something that quickly changes an email subject to add the sender initials, so that I can click it before I add it to a JIRA issue using the Outlook JIRA plugin.
Currently, this is mildly annoying because it has to open the message to change the subject of the email and then when it returns, it moves onto the next message. This adds the mild inconvenience of having to make me move back to the correct message.
I'd be grateful for help figuring out how to make it return to the correct message. Maybe with MailItem.EntryID but I can't figure out how to point to it on close.
Sub EditSubject()
Dim Item As Outlook.MailItem
Dim oInspector As Inspector
Dim strSubject As String
Set oInspector = Application.ActiveInspector
If oInspector Is Nothing Then
Set Item = Application.ActiveExplorer.Selection.Item(1)
Item.Display 'Force the pop-up
Set oInspector = Application.ActiveInspector 'Reassign oInpsector and Item again
Set Item = oInspector.CurrentItem
Else
Set Item = oInspector.CurrentItem
End If
Dim Initials As String
strSubject = Item.Subject
Dim splitName() As String
splitName = Split(Item.SenderName, ",")
Initials = Left$(splitName(1), 2)
Initials = Right$(Initials, 1) + Left$(splitName(0), 1)
Item.Subject = UCase$(Initials) & " - " & strSubject
Item.Close (olSave)
Set Item = Nothing
Set oInspector = Nothing
End Sub
References:
[1] Saving emails with sender's initials
[2] Updating email subject in Outlook VBA
There is no need to open an inspector window for an item. You can change the Subject line without opening an actual item in a new inspector window.
Sub EditSubject()
Dim Item As Outlook.MailItem
Dim oInspector As Inspector
Dim strSubject As String
Set oInspector = Application.ActiveInspector
If oInspector Is Nothing Then
Set Item = Application.ActiveExplorer.Selection.Item(1)
Else
Set Item = oInspector.CurrentItem
End If
Dim Initials As String
strSubject = Item.Subject
Dim splitName() As String
splitName = Split(Item.SenderName, ",")
Initials = Left$(splitName(1), 2)
Initials = Right$(Initials, 1) + Left$(splitName(0), 1)
Item.Subject = UCase$(Initials) & " - " & strSubject
Item.Save
Set Item = Nothing
Set oInspector = Nothing
End Sub
The problem was not reproduced but you can reselect the item.
Option Explicit
Sub EditSubject_PreserveSelection()
Dim Item As mailItem
If ActiveInspector Is Nothing Then
Set Item = ActiveExplorer.Selection.Item(1)
Item.Display 'Force the pop-up
Else
Set Item = ActiveInspector.currentItem
End If
Dim Initials As String
Dim splitName() As String
'splitName = Split(Item.SenderName, ",")
'Initials = Left$(splitName(1), 2)
'Initials = Right$(Initials, 1) + Left$(splitName(0), 1)
'Item.subject = UCase$(Initials) & " - " & strSubject
Item.subject = "Initials" & " - " & Item.subject
Item.Close (olSave)
ActiveExplorer.ClearSelection
ActiveExplorer.AddToSelection Item
Set Item = Nothing
End Sub
I want to replace in the active email the "text1" with "text2" . Here is my code:
Sub Custmod()
Dim olItem As Outlook.MailItem
Dim objOL As Outlook.Application
Dim olOutMail As Outlook.MailItem
Dim sText As String
Dim vText As String
Dim strBody As String
Set objOL = Application
Set objItem = objOL.ActiveInspector.CurrentItem
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.body
vText = Split(sText, Chr(13))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "TEXT1") Then
olItem.body = Replace(vText(i), "TEXT2", "")
Next i
End Sub
Any help is welcomed. Thank you.
It looks like you are trying to use an array when not needed.
Replace works on multiple instances of the same word.
Option Explicit
Sub Custmod()
Dim olItem As mailItem
Set olItem = CreateItem(olMailItem)
olItem.body = "TEXT1" & Chr(13) & "Here is some stuff." & Chr(13) & "TEXT1 again."
olItem.Display
MsgBox olItem.body
olItem.body = Replace(olItem.body, "TEXT1", "TEXT2")
MsgBox olItem.body
Set olItem = Nothing
End Sub
I have a button in Access that opens Outlook, creating an appointment.
Private Sub addAppointEstimate_Click()
Dim objOutlook As Object
Dim objOutLookApp As Object
Dim strSubject As String
Dim strBody As String
strSubject = Forms!frmMain.LastName 'more stuff to add
strBody = DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78") '& Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID)
Set objOutlook = CreateObject("Outlook.Application")
Set objOutLookApp = objOutlook.CreateItem(1)
With objOutLookApp
.subject = strSubject
.RTFBody = StrConv(strBody, vbFromUnicode)
.Display
End With
End Sub
The problem is that I want to insert Rich text into the Body but it doesn't format correctly, as it shows all the HTML tags instead e.g:
<div><strong>example </strong><font color=red>text</font></div>
Is there a way I can send or convert the rich text to Outlook in a format it will recognise? (Maybe using the clipboard)
It seems many people have solution for Excel, but I am struggling to get them to work in Access:
HTML Text with tags to formatted text in an Excel cell
http://dailydoseofexcel.com/archives/2005/02/23/html-in-cells-ii/
To pass RTF formatted string to outlook email body is simple as following
Function RTF2Outlook(strRTF as String) as boolean
Dim myOlApp, myOlItem
Dim arrFiles() As String, arrDesc() As String, i As Long
Set myOlApp = CreateObject("Outlook.Application")
Set myOlItem = myOlApp.CreateItem(olMailItem)
With myOlItem
.BodyFormat = olFormatRichText
.Body = StrConv(strRTF, vbFromUnicode) 'Convert RTF string to byte array
End With
Set myOlApp = Nothing
Set myOlItem = Nothing
End Function
The secret is not to use ".RTFBody" but just ".Body" and pass to it byte array as in the code above. It took me awhile to figure it out.
Thanks to Microsoft we always will have something to figure out.
You can use a little extra overhead to create a message with the formatted HTMLBody content, then copy the content to an Appointment item.
Start by creating a message and an appointment and populating them as desired. Put the body text in the message, skip the body in the appointment for now.
Dim objOutlook As Object
Dim objMyMsgItem As Object
Dim objMyApptItem As Object
Dim strSubject As String
strSubject = "Some text" 'Forms!frmMain.LastName 'more stuff to add
Set objOutlook = CreateObject("Outlook.Application")
Set objMyMsgItem = objOutlook.CreateItem(0) 'Message Item
With objMyMsgItem
.HTMLBody = "<div><strong>example </strong><font color=red>text</font></div>"
'DLookup("EstimateText", "tblEstimateItems", "EstimateID = 78")
.Display
End With
Set objMyApptItem = objOutlook.CreateItem(1) 'Appointment Item
With objMyApptItem
.Subject = strSubject
.Display
End With
Then use the GetInspector property to interact with the body of each item via a Word editor, and copy the formatted text that way.
Dim MyMsgInspector As Object
Dim wdDoc_Msg As Object
Set MyMsgInspector = objMyMsgItem.GetInspector
Set wdDoc_Msg = MyMsgInspector.WordEditor
Dim MyApptInspector As Object
Dim wdDoc_Appt As Object
Set MyApptInspector = objMyApptItem.GetInspector
Set wdDoc_Appt = MyApptInspector.WordEditor
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText
This code is tested and works in Access 2013.
You are setting the plain text Body property. Set the HTMLBody property to a properly formatted HTML string.
I came up with a solution. I have just copied and pasted the entire sub, but the answer is in there I promise. I have also highlighted the important bits.
I works on my home machine, but not on the clients. So I cant use it, but if you can improve on it let me know.
Private Sub addAppointmentEst_Click()
Dim objOutlook As Object
Dim objOutLookApp As Object
Dim strSubject As String
Dim strBody As String
On Error GoTo appointmentEstError
If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
DoCmd.OpenForm "frmEditEstimate", , , , , acHidden '<------ OPEN FORMATTED TEXT IN A FORM
Forms!frmEditEstimate.SetFocus
Forms!frmEditEstimate!frmSubEstimateItems.Form.EstimateText.SetFocus
DoCmd.RunCommand acCmdCopy '<------ COPY FORMATTED TEXT
DoCmd.Close acForm, "frmEditEstimate", acSaveNo
End If
' If Not IsNull(Forms!frmMain.Title.Value) Then
' strSubject = strSubject & Forms!frmMain.Title.Value
' End If
If Not IsNull(Forms!frmMain.FirstName.Value) Then
strSubject = strSubject & Forms!frmMain.FirstName.Value
End If
If Not IsNull(Forms!frmMain.LastName.Value) Then
strSubject = strSubject & " " & Forms!frmMain.LastName.Value
End If
If Not IsNull(Forms!frmMain.Organisation.Value) Then
strSubject = strSubject & " (" & Forms!frmMain.Organisation.Value & ")"
End If
If Not IsNull(Forms!frmMain!frmSubTransaction.Form.Property.Value) Then
strSubject = strSubject & " - " & Forms!frmMain!frmSubTransaction.Form.Property.Value
End If
Set objOutlook = CreateObject("Outlook.Application")
Set objOutLookApp = objOutlook.CreateItem(1)
With objOutLookApp
.subject = strSubject
.Display
End With
If Not IsNull(DLookup("EstimateID", "tblEstimate", "TransactionID = " & Me.TransactionID.Value)) Then
Set objectOutlookBody = objOutlook.ActiveInspector.WordEditor
objOutLookApp.Body = vbCrLf & "Estimate ID: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateID.Value & _
vbCrLf & "Estimate Date: " & Forms!frmMain!frmSubTransaction!frmSubEstimate.Form.EstimateDate.Value
objectOutlookBody.Application.Selection.Paste '<----- PASTE TEXT INTO APPOINTMENT
Forms!frmMain.EmptyValue.Value = " " '<----- EMPTY CLIPBOARD
Forms!frmMain.EmptyValue.SetFocus
DoCmd.RunCommand acCmdCopy
End If
Exit Sub
appointmentEstError:
MsgBox _
Prompt:="Failed create an appointment in Outlook, with the estimate attached", _
Buttons:=vbOKOnly + vbExclamation, _
Title:="Error"
End Sub
As in previous answer, this line is the key, it copies text, hyperlinks, pictures etc. without modifying clipboard content:
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText
I am running the following script on the event that I receive an email from a specific address with a specific subject. The goal is to tag an email with a hyperlink that will be useful for the recipient of said email to have in the original message's body.
Option Explicit
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
'On Error Resume Next
Set objOL = Application
strID = MyMail.EntryID
Set MyMail = Application.Session.GetItemFromID(strID)
If Not MyMail Is Nothing Then
Set objNS = objOL.Session
MyMail.BodyFormat = olFormatHTML
If MyMail.BodyFormat = olFormatHTML Then
MsgBox ("set to html")
End If
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
MsgBox ("Hyperlink appended!")
Else
MsgBox ("Failure!")
End If
End Sub
While I get the message box telling me that the proper event occurred it appears that no actual changes are made (or are not being saved properly?).
This is the first work I have done with any kind of programming. I've gone through some tutorials for VB specifically, but I am very new to this. Any help/guidance is much appreciated!
This is a classic case of needing to use Option Explicit to require explicit variable declarations. Use this, since you are learning VBA. Also avoid the habit of using On Error Resume Next as this ignores all error handling.
You might not realize this but you are referring to your mail item in the following ways:
MyMail
objItem
objMsg
objMail
Note that the following two commands
objMsg.HTMLBody
objMail.Save
are performed on non-existent objects.
Remove the above three extra references:
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objItem As Object
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
end Sub
You also don't need the cleanup either.