The code below displays a message box with the mail subject for every incoming mail. It works well with Latin characters but fails on the Chinese ones.
The message subject is 'FW: Emailing: Copy of 小奶厅整机不同方案配置.xlsx'
But it displays the message box with following text:
New Message Received
Subject : FW: Emailing: Copy of ???????????.xlsx
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private 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
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
MessageInfo = "Subject : " & Item.Subject & vbCrLf
Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
Related
This code works perfectly for a normal inbox, but how to change the code to trigger an acknowledgement (only for new mails, need to exclude Re and Forward mails the comes to the inbox folder) from a shared mailbox (xxx#mail.com).folder(inbox)
how to modify this code to trigger from a specific shared mailbox "Inbox"
Public WithEvents xlItems As Outlook.Items
Private Sub Application_Startup()
Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Full Code:
Public WithEvents xlItems As Outlook.Items
Private Sub Application_Startup()
Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub xlItems_ItemAdd(ByVal objItem As Object)
Dim xlReply As MailItem
Dim xStr As String
If objItem.Class <> olMail Then Exit Sub
Set xlReply = objItem.Reply
With xlReply
xStr = "<p>" & "Hi Team, Acknowledging that we have received the Job. Thank you!" & "</p>"
.HTMLBody = xStr & .HTMLBody
.Send
End With
End Sub
I tried Modifying the code but it did not work
Option Explicit
Private WithEvents olInboxItems As Items
Dim objNS As NameSpace
Set objNS = Application.Session
' instantiate objects declared WithEvents
Set olInboxItems = objNS.Folders("xxxxxxxx#gmail.com").Folders("Inbox").Items
Set objNS = Nothing
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim xlReply As MailItem
Dim xStr As String
If objItem.Class <> olMail Then Exit Sub
Set xlReply = objItem.Reply
With xlReply
xStr = "<p>" & "Hi Team, Acknowledging that we have received the Job. Thank you!" & "</p>"
.HTMLBody = xStr & .HTMLBody
.Send
End Sub
This should be more robust than checking for "Re: " and "Fw: " in the subject.
In ThisOutlookSession
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public WithEvents olItems As Items
Private Sub Application_Startup()
Set olItems = Session.Folders("xxxx#xxx.com").Folders("Inbox").Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim olReply As MailItem
If Item.Class = olMail Then
If Len(Item.ConversationIndex) > 44 Then
Exit Sub
Else
Set olReply = Item.reply
With olReply
.Body = "Reply to first email."
.Display
End With
End If
End If
End Sub
I figured the code myself finally. But it sends out mail for all the emails including (RE and FWD)
Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set olItems = objNS.Folders("xxxx#xxx.com").Folders("Inbox").Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim olReply As MailItem
If Item.Class = olMail Then
Set olReply = Item.Reply
Else
Exit Sub
End If
With olReply
'Type Your Own Auto Reply
'Change "John Smith" to Your Own Name
.Body = "This is a test auto reply." & vbCrLf & vbCrLf & "-------Original Message-------" & vbCrLf & "From: " & Item.Sender & "[mailto: " & Item.SenderEmailAddress & "]" & vbCrLf & "Sent: " & Item.ReceivedTime & vbCrLf & "To: YourName" & vbCrLf & "Subject: " & Item.Subject & vbCrLf & Item.Body
.Send
End With
End Sub
This is the primitive / intuitive version.
Subject must remain unchanged and be in English.
In ThisOutlookSession
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public WithEvents olItems As Items
Private Sub Application_Startup()
Dim objNS As namespace
Set objNS = GetNamespace("MAPI")
Set olItems = objNS.Folders("xxxx#xxx.com").Folders("Inbox").Items
End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
Dim olReply As MailItem
If Item.Class = olMail Then
If Left(UCase(Item.Subject), 4) = UCase("Re: ") Or _
Left(UCase(Item.Subject), 4) = UCase("Fw: ") Then
Exit Sub
Else
Set olReply = Item.reply
With olReply
.Body = "Reply to first email."
.Display
End With
End If
End If
End Sub
There are several mail accounts in outlook.
There is a code, that generates a message box with the properties of the new mail in the primary mailbox. It works for my primary mail account.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private 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
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
MessageInfo = "" & _
"Sender : " & Item.SenderEmailAddress & vbCrLf & _
"Sent : " & Item.SentOn & vbCrLf & _
"Received : " & Item.ReceivedTime & vbCrLf & _
"Subject : " & Item.Subject & vbCrLf & _
"Size : " & Item.Size & vbCrLf & _
"Message Body : " & vbCrLf & Item.Body
Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
Here is what the pop-up message looks like:
There is another mailbox "Specification Estimation RU41". My task is to get the same pop-up message for new incoming mail to this mailbox.
I replaced the line
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
with
Set inboxItems = objectNS.Folders("Specification Estimation RU41") _
.Folders("Inbox").Items
so that whole code looks like this:
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private 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.Folders("Specification Estimation RU41") _
.Folders("Inbox").Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
MessageInfo = "" & _
"Sender : " & Item.SenderEmailAddress & vbCrLf & _
"Sent : " & Item.SentOn & vbCrLf & _
"Received : " & Item.ReceivedTime & vbCrLf & _
"Subject : " & Item.Subject & vbCrLf & _
"Size : " & Item.Size & vbCrLf & _
"Message Body : " & vbCrLf & Item.Body
Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
But this doesn't work. No error messages, but no reaction at the new mails.
How can I make it work?
Have you tried working with NameSpace.GetSharedDefaultFolder method (Outlook) MSDN
This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders
Example
Private WithEvents RU41_Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Set olNs = Application.GetNamespace("MAPI")
Dim RU41_Recip As Outlook.Recipient
Set RU41_Recip = olNs.CreateRecipient("0m3r#email.com")
Dim RU41_Inbox As Outlook.MAPIFolder
Set RU41_Inbox = olNs.GetSharedDefaultFolder(RU41_Recip, olFolderInbox)
Set RU41_Items = RU41_Inbox.Items
End Sub
Private Sub RU41_Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
DoEvents
'''code here
End If
End Sub
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'm trying to set up a macro in ThisOutlookSession to save attachments to file.
I previously used rules and 'run a script', but it is not enabled for all users.
The below code either returns a 91 error (object or variable not set), or it runs without error, but doesn't save.
The code is looking at a subfolder, to save all attachments to a location based on subject. The emails are sent to the subfolder through a rule.
I want to rename the attachments based on the ReceivedTime, and I think this is where the issue arises. If I use Msg.ReceivedTime, I get the 91 error. If I use Item.ReceivedTime, there is no error, but the file is not saved.
Here is the source where I derived most of the code and customized. https://www.tachytelic.net/2017/10/how-to-run-a-vba-macro-when-new-mail-is-received-in-outlook/
Private WithEvents folderItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set folderItems = objectNS.GetDefaultFolder(olFolderInbox).Folders("Operations").Folders("Test").Items
End Sub
Private Sub folderItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim att As Outlook.Attachment
Dim msg As Outlook.MailItem
Dim filepath As String, filedate As String
filepath = "C:\Documents\"
filedate = Format(Item.ReceivedTime, "YYYYMMDD") 'This is the line which I think is the problem. If I do Msg.ReceivedTime, I get 91 error, but if I do Item.ReceivedTime, it does not save
If TypeName(Item) = "MailItem" Then
If InStr(Item.Subject, "XXX") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "XXX\" & filedate & "_raw.csv"
Next
ElseIf InStr(Item.Subject, "YYY") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "YYY\" & filedate & "_raw.xlsx"
Next
ElseIf InStr(Item.Subject, "ZZZ") > 0 Then
For Each att In Item.Attachments
att.SaveAsFile filepath & "ZZZ.csv"
Next
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
My hypothesis is that the ReceivedTime is the issue. If I can use Msg.ReceivedTime, how do I set the variable? Or, if Item.ReceivedTime is correct, why does it not save?
Try the following
Dim att As Outlook.attachment
Dim msg As Outlook.MailItem
Dim filepath As String, filedate As String
filepath = "C:\Documents\"
If TypeName(Item) = "MailItem" Then
Set msg = Item
Debug.Print msg.ReceivedTime ' print on Immediate Window
filedate = Format(msg.ReceivedTime, "YYYYMMDD")
If InStr(msg.Subject, "XXX") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "XXX\" & filedate & "_raw.csv"
Next
ElseIf InStr(msg.Subject, "YYY") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "YYY\" & filedate & "_raw.xlsx"
Next
ElseIf InStr(msg.Subject, "ZZZ") > 0 Then
For Each att In msg.Attachments
att.SaveAsFile filepath & "ZZZ.csv"
Next
End If
End If
also you don't need outlookApp when the code is running within Outlook Application, simply use Application.
Example
Private Sub Application_Startup()
Dim objectNS As Outlook.NameSpace
Set objectNS = Application.GetNamespace("MAPI")
Set folderItems = objectNS.GetDefaultFolder(olFolderInbox) _
.Folders("Operations") _
.Folders("Test").Items
End Sub
I am working on a code which attachment will be download to folder location in context to subject by using a subject filter.
After a long search on the internet, my code is working but the problem here is that I want to put the keyword in the subject filter so that it will download the attachment as the subject keep changing every day
e.g. Sub: training_24357 on one day and training_24359 on the next day.
Also, I want to run my code after every 5 minutes automatically, any help will be much appreciated,
below is my code.
Sub Attachment()
Dim OutOpened As Boolean
Dim App As Outlook.Application
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim Attach As Outlook.Attachment
Dim Item As Object
Dim MailItem As Outlook.MailItem
Dim subject As String
Dim saveFolder As String
Dim dateFormat As String
saveFolder = "D:\Outlook\POS Visit Report"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
subject = """*POS Visit*"""
OutOpened = False
On Error Resume Next
Set App = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set App = New Outlook.Application
OutOpened = True
End If
On Error GoTo 0
If App Is Nothing Then
MsgBox "Cannot Start Outlook Mail", vbExclamation
Exit Sub
End If
Set Ns = App.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
If Not olFolder Is Nothing Then
For Each Item In olFolder.Items
If Item.Class = Outlook.ObjectClass.olMail Then
Set MailItem = Item
If MailItem.subject = subject Then
Debug.Print MailItem.subject
For Each Attach In MailItem.Attachments
dateFormat = Format(Now(), "yyyy-mm-dd H-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
Next
End If
End If
Next
End If
If OutOpened Then App.Quit
Set App = Nothing
End Sub
To Search for Items with Attachment and by Subject line you can use Items.Restrict Method to filter Items collection containing all the match from the filter
Filter Example: [Attachment & Subject Like '%training%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%training%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
VBA Example https://stackoverflow.com/a/42547062/4539709 Or https://stackoverflow.com/a/42777485/4539709
Now if your running the code from Outlook then you do not need to GetObject, or Set App = New Outlook.Application Just simply Set Ns = Application.GetNamespace("MAPI")
To run your code when Items are added to you Inbox - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)
Items.ItemAdd Event Occurs when one or more Items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.
Code Example:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
'// call sub here
End If
End Sub