Im trying to write condition and depending on which recipient has an email forward it to another email. After searching in web I found following but its not work for me:
Public Sub ConvertMeetingToEmail(ActiveFolder, Inbox As String)
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim Subfolder As Outlook.Folder
Dim Item As Object
Dim myMtg As Outlook.MeetingItem
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.Folders(ActiveFolder)
Set Folders = myFolder.Folders
Set Subfolder = Folders.Item(Inbox)
For Each Item In Subfolder.Items
If Item.MessageClass = "IPM.Schedule.Meeting.Request" Then
Set Msg = Item
Set recips = Msg.Recipients
For Each recip In recips
If (recip = "example#mail.domail" _
Or recip = "example1#mail.domail" _
Or recip = "example2#mail.domail" _
Or recip = "example3#mail.domail" _
Or recip = "example4#mail.domail") Then
objMsg.To = "example6#mail.domail"
objMsg.CC = recip
objMsg.Subject = Msg.Subject
objMsg.Body = Msg.Body
objMsg.Send
Endif
Next
End If
Next
End Sub
Recipients collection returns Recipient objects, not strings, so your code should be checking the recip.Address property. It is also a good idea to use case insensitive string comparison:
If ((StrComp(recip.Address, "example#mail.domail", 1) = 0) _
...
Related
I copy an email from a shared mailbox to a local folder in my Outlook.
I am trying to forward the email from my local email account.
When I do this, it is sent from the shared mailbox account.
I set the account on the email as the confirmed correct account.
mailItem.Move myDestFolder
Set mailItem2 = mailItem.Forward
mailItem2.SendUsingAccount = oAccount (where oAccount is OutApp.Session.Accounts.Item (1))
mailItem2.Send
set mailItem2.SendUsingAccount = oAccount results in error
Property is Read-Only
Wondering if I don't have permissions to set this?
Option Explicit
Private rcvMail As Outlook.MailItem
Private fwMail As Outlook.MailItem
Private Const STR_MOVED_FOLDER As String = "Moved Emails"
Sub MoveAndForward()
Dim myNamespace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim rcvFolder As Outlook.Folder
Dim oAccount As Outlook.Account
Dim myItems As Outlook.Items
Dim myItem As Object
Dim OutApp1 As Object
Dim mailBoxFolderName As String
Dim iEmailAccount As Integer
Dim iRecipientCount As Integer
Dim i As Integer
Set OutApp1 = CreateObject("Outlook.Application")
Set oAccount = OutApp1.Session.Accounts.Item(1)
Set myNamespace = Application.GetNamespace("MAPI")
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
CheckOrCreateFolder
Set myDestFolder = myInbox.Folders(STR_MOVED_FOLDER)
Set rcvMail = ReturnCurrentItem()
If rcvMail.Class <> olMail Then
MsgBox "This cannot be saved to file." & vbCrLf & _
"Only Mail Items are supported.", vbExclamation, "Error"
Exit Sub
End If
Set rcvFolder = rcvMail.Parent
mailBoxFolderName = rcvFolder.Name
rcvMail.Move myDestFolder
Set fwMail = rcvMail.Forward
Set fwMail.SendUsingAccount = oAccount
iRecipientCount = fwMail.Recipients.Count
If iRecipientCount > 0 Then
For i = iRecipientCount To 1 Step -1
fwMail.Recipients.Remove (i)
Next i
End If
fwMail.Recipients.Add "*****#***.com"
fwMail.Recipients.ResolveAll
fwMail.Body = myNamespace.CurrentUser & " Took this email from the Mailbox" & _
vbCrLf & rcvMail.Body
fwMail.Send
rcvMail.Close (olDiscard)
Set rcvMail = Nothing
Set fwMail = Nothing
Set myNamespace = Nothing
Set myInbox = Nothing
Set myItems = Nothing
Set myDestFolder = Nothing
End
End Sub
I created a rule to run a script on all incoming email. The script checks if the email has any attachments and checks their type. Mails which have only .pdf attachments, stay in the inbox, the rest goes to Error folder. The script also ignores hidden attachments.
This works on my own Outlook mailbox. The problem is that it has to work on a shared mailbox.
I modified the rule so it would take into consideration only the messages arriving at a shared mailbox, but it's not working, even if I set up a rule without any script.
I tried to change the script, but the only thing I managed to achieve is moving the pdf-less emails from my inbox to Error folder in shared inbox.
Here is the script that works with my own mailbox:
Sub PDF(Item As Outlook.MailItem)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Error")
End If
Set myAtt = Nothing
Set pa = Nothing
End Sub
I tried this script, but it's not working:
Sub PDF4(Item As Outlook.MailItem)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("test#mailbox.com")
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders(olFolderInbox)
Set colItems = objFolder.Items
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
For Each Item In objFolder.Items
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move objInbox.Folders("Error")
End If
Set myAtt = Nothing
Set pa = Nothing
End Sub
There are two problems:
Is it possible to set up a rule that takes into consideration only the messages which arrive at the shared inbox? The current rule checks only the emails, which arrive at my inbox. (I have no option in Rule Management to "Apply changes to this folder:".)
If not possible, I could always make the script work through macro.
How should the code be written? Maybe it's ok and is not working only because of the rule. Is it possible to make a script that checks the attachments only of the messages that arrive at the shared inbox?
#niton suggested using ItemAdd and it worked. Now the script checks emails in shared inbox.
Thank you for help!
Solution:
It has to be put inside ThisOutlookSession
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Dim Recip As Outlook.Recipient
Set Recip = objNS.CreateRecipient("test#mail.com")
Set objWatchFolder = objNS.GetSharedDefaultFolder(Recip, olFolderInbox)
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
Set Recip = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
Dim myAtt As Outlook.Attachment
Dim allPdf As Boolean
Dim hidNum As Integer
allPdf = True
hidNum = 0
Dim pa As PropertyAccessor
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Dim Recip As Outlook.Recipient
Set Recip = objNS.CreateRecipient("test#mail.com")
Set objWatchFolder = objNS.GetSharedDefaultFolder(Recip, olFolderInbox)
For Each myAtt In Item.Attachments
Debug.Print myAtt.DisplayName
Set pa = myAtt.PropertyAccessor
If pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
hidNum = hidNum + 1
Else
If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) And Right(LCase(myAtt.FileName), 4) <> ".pdf" Then
allPdf = False
End If
End If
Next
If allPdf = False Or Item.Attachments.Count = hidNum Then
Item.Move objWatchFolder.Parent.Folders("Error")
End If
Set Item = Nothing
Set myAtt = Nothing
Set pa = Nothing
Set objWatchFolder = Nothing
Set Recip = Nothing
End Sub
I'm sure the code could be more optimized, but "it just works".
I'm looking to use the get function in vba in order to activate a specific email in Outlook and then copy the body into a new email and send. I can use the getlast function to get the latest email in the inbox, however I would like to refine the code some more by selecting the latest email from a specific email address.
Also, I'd love how to know how to delete the signature from the text pasted into the new email.
Sub Negotiations()
Dim objMsg As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim BodyText As Object
Dim myinspector As Outlook.Inspector
Dim myItem As Outlook.MailItem
Dim NewMail As MailItem, oInspector As Inspector
Set myItem = Application.Session.GetDefaultFolder(olFolderInbox).Items.GetLast
myItem.Display
'copy body of current item
Set activeMailMessage = ActiveInspector.CurrentItem
activeMailMessage.GetInspector().WordEditor.Range.FormattedText.Copy
' Create the message.
Set objMsg = Application.CreateItem(olMailItem)
'paste body into new email
Set BodyText = objMsg.GetInspector.WordEditor.Range
BodyText.Paste
'set up and send notification email
With objMsg
.To = "#gmail.com"
.Subject = "Negotiations"
.HTMLBody = activeMailMessage.HTMLBody
.Display
End With
End Sub
any help would be appreciated, thank you guys!
Open the Inbox folder using Namespace.GetDefaultFolder(olFolderInbox), retrieve the Items collection from MAPIFolder.Items. Sort the items (Items.Sort) on the ReceivedTime property, retrieve the latest email using Items.Find on the SenderEmailAddress property.
Dependant on what your property of .SenderEmailAddress returns, you can adapt what the while statement evaluates for. This should work for you, by first looking at the last e-mail, and then checking each previous e-mail for the correct sender address.
Sub display_mail()
Dim outApp As Object, objOutlook As Object, objFolder As Object
Dim myItems As Object, myItem As Object
Dim strSenderName As String
Set outApp = CreateObject("Outlook.Application")
Set objOutlook = outApp.GetNamespace("MAPI")
Set objFolder = objOutlook.GetDefaultFolder(olFolderInbox)
Set myItems = objFolder.Items
strSenderName = UCase(InputBox("Enter the e-mail Alias."))
Set myItem = myItems.GetLast
While Right(myItem.SenderEmailAddress, Len(strSenderName)) <> strSenderName
Set myItem = myItems.GetPrevious
Wend
myItem.Display
End Sub
Application.Session.GetDefaultFolder(olFolderInbox).Items.GetLast
activeMailMessage.GetInspector().WordEditor.Range.FormattedText.Copy
First of all, I'd recommend breaking the chain of calls. Declare each property or method call on a separate line of code, so you will be able to debug the code at any time and see what happens under the hood.
The GetLast method returns the last object in the collectio. But it doesn't mean that the item is recieved last. You need to sort the collection using the Sort method as Dmitry suggested passing the ReceivedTime property as a parameter to sort on. Only in that case you will get the last recieved item from the collection.
The Outlook object model doesn't provide any special method or property for identifying signatures. You need to parse the message body and find it programmatically.
Sub Nego()
Dim objMsg As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim BodyText As Object
Dim Inspector As Outlook.MailItem
Dim olNameSpace As Outlook.NameSpace
Dim olfolder As Outlook.MAPIFolder
Dim msgStr As String
Dim endStr As String
Dim endStrStart As Long
Dim endStrLen As Long
Dim myItems As Outlook.Items
'Access folder Nego
Const olFolderInbox = 6
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
strFolderName = objInbox.Parent
Set objMailbox = objNamespace.Folders(strFolderName)
Set objFolder = objMailbox.Folders("Nego")
'Mark as read
For Each objMessage In objFolder.Items
objMessage.UnRead = False
Next
'Sort
Set myItems = objFolder.Items
For Each myItem In myItems
myItems.Sort "Received", False
Next myItem
myItems.GetLast.Display
'copy body of current item
Set activeMailMessage = ActiveInspector.CurrentItem
activeMailMessage.GetInspector().WordEditor.Range.FormattedText.Copy
' Create the message.
Set objMsg = Application.CreateItem(olMailItem)
'paste body into new email
Set BodyText = objMsg.GetInspector.WordEditor.Range
BodyText.Paste
'Search Body
Set activeMailMessage = ActiveInspector.CurrentItem
endStr = "first line of signature"
endStrLen = Len(endStr)
msgStr = activeMailMessage.HTMLBody
endStrStart = InStr(msgStr, endStr)
activeMailMessage.HTMLBody = Left(msgStr, endStrStart + endStrLen)
'set up and send email
With objMsg
.To = "#email"
.Subject = "Nego"
.HTMLBody = activeMailMessage.HTMLBody
.HTMLBody = Replace(.HTMLBody, "First line of signature", " ")
.Send
End With
End Sub
I want to change recipient's email address when sending a message. I don't know if I should work with item.to or rec.addressentry or myrecipient.
I want it to work like when you enter example#mail.com then it will send it to example2#mail.com, it can rewrite while pressing send button or just send to the example2.
I want to to start the macro at the startup so it should be after startup event and I guess it should be itemsend event.
I tried these:
not working
'Item = MailItem
If Item.To = "example#mail.com" Then
Item.To = "example2#mail.com"
does not close the message window
If Item.Class <> olMail Then Exit Sub
Dim newEm As String
Dim Rec As Recipient
Dim myItem As Outlook.MailItem
Dim myRecipient As Outlook.Recipient
Set myItem = Application.CreateItem(olMailItem)
myItem.Body = Item.Body
myItem.HTMLBody = Item.HTMLBody
myItem.Subject = Item.Subject
Cancel = True
If InStr(1, Rec.AddressEntry, "example#mail.com", vbTextCompare) Then
newEm = "example2#mail.com"
End If
Set myRecipient = myItem.Recipients.Add(newEm)
myRecipient.Type = Rec.Type
Next
myItem.Send
End Sub
Try this:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.To = ChangeSMTPRecipient(Item, "example#mail.com", "example2#mail.com")
End Sub
Function ChangeSMTPRecipient(mail As Outlook.MailItem, FromSMTP, ToSMTP) As String
On Error Resume Next
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
ChangeSMTPRecipient = ""
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
RecipNew = pa.GetProperty(PR_SMTP_ADDRESS)
If RecipNew = FromSMTP Then RecipNew = ToSMTP
ChangeSMTPRecipient = ChangeSMTPRecipient & IIf(ChangeSMTPRecipient = "", "", "; ") & RecipNew
Next
On Error GoTo 0
End Function
I have a user who wants to redirect any email to other people in their department so that when that person replies to the email it will go back to the person who originally sent it.
I am trying to make VBA code to forward all emails in a specified folder and change the reply to address so that they don't have to manually put it in every time.
Sub SendFolder()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
Dim ObjMail As Outlook.MailItem
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set MyFolder = Application.Session.Folders("me#us.com").Folders("test")
For i = MyFolder.Items.Count To 0 Step -1
Set ObjMail.Subject = MyFolder.Itmes(i).Subject
Set ObjMail.ReplyRecipients = MyFolder.Itmes(i).ReplyRecipients
Set ObjMail.Body = MyFolder.Itmes(i).Body
Set ObjMail.Attachments = MyFolder.Itmes(i).Attachments
Set ObjMail.BodyFormat = MyFolder.Itmes(i).BodyFormat
Set ObjMail.To = "test#us.com"
ObjMail.Send
Next
End Sub
You are missing
Set ObjMail = Application.CreateItem(olMailItem)
Then your code would become
With ObjMail
.Subject = MyFolder.Itmes(i).Subject
.ReplyRecipients = MyFolder.Items(i).ReplyRecipients
.Body = MyFolder.Items(i).Body
.Attachments = MyFolder.Items(i).Attachments
.BodyFormat = MyFolder.Items(i).BodyFormat
.To = "test#us.com"
.Send
End with
It it runs now, the ReplyTo does not change.
You will want to set the ObjMail's ReplyRecipients property
Something like .ReplyRecipients.Add MyFolder.Items(i).SenderEmailAddress
To simplify the issue, .Forward the mail as is, and set only the ReplyRecipients property.
Check out this alternative. The mail is sent as an attachment. The receiver automatically replies to the original sender.
Untested
Sub SendFolderItemsAsAttachments()
' Run this VBA code while in Outlook
Dim MyFolder As MAPIFolder
Dim notMyItems as Items
Dim notReplyingToMe as mailitem
Dim i as long
Set MyFolder = Application.Session.Folders("me#us.com").Folders("test")
Set notMyItems = MyFolder.Items
For i = notMyItems.Count To 1 Step -1
If TypeOf notMyItems(i) Is MailItem Then
Set notReplyingToMe = Application.CreateItem(olMailItem)
With notReplyingToMe
.Subject = notMyItems(i).Subject & " - " & _
notMyItems(i).SenderName
.HTMLBody = "Redirecting for your action."
.Attachments.Add notMyItems(i), olEmbeddeditem
.To = "test#us.com"
.Send
End With
notMyItems(i).Delete
End If
Next
Set MyFolder = = Nothing
Set notMyItems = Nothing
Set notReplyingToMe = Nothing
End Sub