The below code (I pulled from several sources) now works in that when I receive an email with specific words in the subject line it triggers a script that runs the below.
This code then keeps the subject line, adds text the message body and the forwards to the intended recipient.
However, if the email I receive has an attachment the code no longer forwards anything. I need it to forward the attachment that was emailed to me as well (only using the code to add text to body of email otherwise I would just set a rule).
CODE BELOW:
Sub ForwardEmail(item As Outlook.MailItem)
Dim oExplorer As Outlook.Explorer
Dim oMail As MailItem
Set oExplorer = Application.ActiveExplorer
On Error GoTo Release
If oExplorer.Selection.item(1).Class = olMail Then
Set oMail = item.Forward
oMail.Subject = oMail.Subject
oMail.HTMLBody = "Have a nice day." & vbCrLf & oMail.HTMLBody
oMail.Recipients.Add "email address here"
oMail.Save
oMail.Send
End If
Release:
Set oMail = Nothing
Set oExplorer = Nothing
End Sub
There is no need to use the Explorer object in the code:
Sub ForwardEmail(item As Outlook.MailItem)
Dim oMail As MailItem
On Error GoTo Release
If item.Class = olMail Then
Set oMail = item.Forward
oMail.Subject = oMail.Subject
oMail.HTMLBody = "Have a nice day." & vbCrLf & oMail.HTMLBody
oMail.Recipients.Add "email address here"
oMail.Save
oMail.Send
End If
Release:
Set oMail = Nothing
Set oExplorer = Nothing
End Sub
You may find the Getting Started with VBA in Outlook 2010 article helpful.
There is an unnecessary condition
If oExplorer.Selection.item(1).Class = olMail Then
that may cause the forwarding to be bypassed.
Sub ForwardEmail(item As Outlook.MailItem)
' Dim oExplorer As Outlook.Explorer
Dim oMail As MailItem
' Set oExplorer = Application.ActiveExplorer
On Error GoTo Release
' If oExplorer.Selection.item(1).Class = olMail Then
Set oMail = item.Forward
oMail.Subject = oMail.Subject
oMail.HTMLBody = "Have a nice day." & vbCrLf & oMail.HTMLBody
oMail.Recipients.Add "email address here"
' oMail.Save
oMail.Send
' End If
Release:
Set oMail = Nothing
' Set oExplorer = Nothing
End Sub
Related
I'm trying to send a message to my phone when I receive mail at work.
The macro should send mail to an sms service that converts the mail to an sms and sends it to my phone. The message will contain the mail sender address and the send and receive times.
I have put together two macros I found by searching the internet.
The first code is on this link tachytelic.net
The second I found here
stackoverflow.com
Here is the part of the code that fails.
'variable for select case
Dim EmailFrom As String
Dim OldMessage As Outlook.MailItem
Set OldMessage = Application.ActiveInspector.CurrentItem
'Puts sender mail address in variable both ordinary mail and Exchange emails.
Select Case OldMessage.SenderEmailType
Case "EX"
EmailFrom = OldMessage.Sender.GetExchangeUser.PrimarySmtpAddress
Case Else
EmailFrom = OldMessage.SenderEmailAddress
End Select
'Sends E-mail to sms service.
If TypeName(Item) = "MailItem" Then
With olEmail
.BodyFormat = olFormatPlain
.To = "some#mail.com"
.Subject = "You got a new E-mail!"
.Body = EmailFrom & vbCrLf & "Sendt: " & Item.SentOn & vbCrLf & "Modtaget: " & Item.ReceivedTime
.Send
End With
End If
I get
runtime error 91 - Object variable or With block variable not set.
I tried to use the F8 key but that isn't possible, I don't know why.
Then I took the original code and pasted it in a module. Then I can use the F8 key to go through the code.
The error comes when I reach this line.
Set OldMessage = Application.ActiveInspector.CurrentItem
Here is the whole code
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
'variable for if statments
Dim olApp As Outlook.Application
Dim olEmail As Outlook.MailItem
Set olApp = New Outlook.Application
Set olEmail = olApp.CreateItem(olMailItem)
'variable for select case
Dim EmailFrom As String
Dim OldMessage As Outlook.MailItem
'Deletes sms status mails I recieve when I mail to sms service
If InStr(Item.Subject, "SMS status") > 0 Then
Item.UnRead = False
Item.Save
Item.Delete
End
End If
'Puts sender mail address in variable both ordinary mail and Exchange emails.
Select Case OldMessage.SenderEmailType
Case "EX"
EmailFrom = OldMessage.Sender.GetExchangeUser.PrimarySmtpAddress
Case Else
EmailFrom = OldMessage.SenderEmailAddress
End Select
'Sends E-mail to sms service.
If TypeName(Item) = "MailItem" Then
With olEmail
.BodyFormat = olFormatPlain
.To = "some#mail.com"
.Subject = "You got a new E-mail!"
.Body = EmailFrom & vbCrLf & "Sendt: " & Item.SentOn & vbCrLf & "Modtaget: " & Item.ReceivedTime
.Send
End With
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
Then it is easier to get an overview.
How do I get the ActiveInspector to se the recieved mail and save it in the OldMessage?
If there is no open item window of any kind, ActiveInspector will be Nothing. Also, based on your supplied code sample, the Item variable is not declared or set anywhere, so you'll likely also get an error on this line:
If TypeName(Item) = "MailItem" Then
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
I am sending email on behalf of a Shared MailBox - generic system account?
How do I update the sender in Outlook mail?
I am getting a Run-Time error '438': Object doesn't support this property or method .From = "MYACCOUNT#ACCOUNT.com"
Function CreateEmail(MySQL As String)
'On Error GoTo Exit_Function:
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem 'rs As Recordset
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset(MySQL)
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF
If IsNull(rs!standard_e_mail_addr) Then
rs.MoveNext
Else
If oOutlook Is Nothing Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.To = rs!standard_e_mail_addr
.From = "MYACCOUNT#ACCOUNT.com" ' **
.Subject = "Mandatory Action Required Submit In-Person Identification Form for " & rs!emp_fname
.Body = "EmpNo: " & rs!emp_no & vbCr & _
"EmpName: " & rs!emp_fname & vbCr & _
"DO NOT REPLY."
.Display
.Send
rs.Edit
rs!EmailNotification_Send = Date
rs.Update
End With
Set oEmailItem = Nothing
Set oOutlook = Nothing
rs.MoveNext
End If
Loop
Else
End If
rs.Close
Exit Function:
Exit Function
End Function
Okay, try: .SentOnBehalfOfName = """SenderName"" <MyAccount#Address.com>"
Also review: Use another account for sender
First of all, there is no need to call Display before calling the Send method.
If you have the shared mailbox configured in Outlook you need to use the SendUsingAccount property which allows to set an Account object that represents the account under which the MailItem is to be sent. For example:
Sub SendUsingAccount()
Dim oAccount As Outlook.account
For Each oAccount In Application.Session.Accounts
If oAccount.AccountType = olPop3 Then
Dim oMail As Outlook.MailItem
Set oMail = Application.CreateItem(olMailItem)
oMail.Subject = "Sent using POP3 Account"
oMail.Recipients.Add ("someone#example.com")
oMail.Recipients.ResolveAll
oMail.SendUsingAccount = oAccount
oMail.Send
End If
Next
End Sub
Use SentOnBehalfOfName as long as your Exchange account has SendAs permission for the shared mailbox or distribution group, it will be sent from the shared account or group, not sent on behalf of.
With oEmailItem
.To = rs!standard_e_mail_addr
.SentOnBehalfOfName = "MYACCOUNT#ACCOUNT.com"
.Subject = "Mandatory Action Required Submit In-Person Identification Form for " & rs!emp_fname
.Body = "EmpNo: " & rs!emp_no & vbCr & _
"EmpName: " & rs!emp_fname & vbCr & _
"DO NOT REPLY."
.Send
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
Can someone please show me how to add a "Cc recipient" to this code? The "To Recipient" and code all work as intended. Thank you for your time.
Sub ForwardEmail(item As Outlook.MailItem)
' Dim oExplorer As Outlook.Explorer
Dim oMail As MailItem
' Set oExplorer = Application.ActiveExplorer
On Error GoTo Release
' If oExplorer.Selection.item(1).Class = olMail Then
Set oMail = item.Forward
oMail.Subject = oMail.Subject
oMail.HTMLBody = "Have a nice day." & vbCrLf & oMail.HTMLBody
oMail.Recipients.Add "email address here"
' oMail.Save
oMail.Send
' End If
Release:
Set oMail = Nothing
' Set oExplorer = Nothing
End Sub
set oRecip = oMail.Recipients.Add("email address here")
oRecip.Type = olCC
or
oMail.CC = "email address here"