I'm working within MS Access 2013 and MS Outlook 2013 on Windows 10 and I have a Access DB with a "Navigation Subforms" paradigm that allows sending a single e-mail on two separate occasions.
I'm trying to write code to do the following:
when a new e-mail is sent,
I want to save it as a .msg file on disk automatically.
From what I can tell, it seems the way to do this is via trapping the .ItemAdd event that fires on Outlook Sent Folder within Access, and in there executing the .SaveAs method.
I was trying to implement a solution based on these two answers:
How to Trap Outlook Events from Excel Application
Utilizing Outlook Events From Excel
but I just can't seem to combine the two and make the event fire.
My feeling is that either I'm not referencing/setting things correctly or the execution reaches an end before the e-mail is moved from the Outbox Folder to the Sent Folder, but I'm not sure.
How can I do this?
Thanks for reading, code follows:
My current class module - "cSentFolderItem"
Option Explicit
Public WithEvents myOlItems As Outlook.items
Private Sub Class_Initialize()
Dim oNS As NameSpace
Dim myOL As Outlook.Application
Set myOL = New Outlook.Application
Set oNS = myOL.GetNamespace("MAPI")
Set myOlItems = oNS.GetDefaultFolder(olFolderSentMail).items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
Debug.Print "I got a new item on Sent box!"
Dim myOlMItem As Outlook.MailItem
Set myItem = myOlItems.items(email_subject)
myItem.Display
myItem.SaveAs "C:\Users\XXXXXX\Desktop\mail_test.msg", olMSGUnicode
End Sub
"Regular" code:
Public Function GetApplication(Class As String) As Object
'Handles creating/getting the instance of an application class
Dim ret As Object
On Error Resume Next
Set ret = GetObject(, Class)
If Err.Number <> 0 Then
Set ret = CreateObject(Class)
End If
Set GetApplication = ret
On Error GoTo 0
End Function
Sub Test()
email_subject = "Mail test match string - [aaaa-mm-dd]"
Set myOlItems = New cSentFolderItem 'declare class module object
Dim MyOutlook As Outlook.Application
Set MyOutlook = GetApplication("Outlook.Application") 'trying to get correct application object
'The following code is a dummy e-mail creation, after which I press SEND:
Dim MyMail As Outlook.MailItem
varTo = "target_email#address.com"
varSubject = email_subject
varbody = "test line 1" & vbCrLf & "test line 2" & vbCrLf & "test line 2"
varSubject = Replace(varSubject, "[aaaa-mm-dd]", NOW())
Dim linhas() As String
linhas = Split(varbody, vbCrLf)
bodyHTMLtext = "<body>"
For i = 0 To UBound(linhas) - 1
bodyHTMLtext = bodyHTMLtext & linhas(i) & "<br>"
Next
bodyHTMLtext = bodyHTMLtext & linhas(UBound(linhas))
bodyHTMLtext = bodyHTMLtext & "</body>"
Set MyMail = MyOutlook.CreateItem(OLMAILITEM)
MyMail.To = varTo
MyMail.Subject = varSubject
MyMail.Display
MyMail.HTMLBody = bodyHTMLtext & MyMail.HTMLBody
AppActivate varSubject
'trying to leave Outlook object open:
''Cleanup after ourselves
'Set MyMail = Nothing
''MyOutlook.Quit
'Set MyOutlook = Nothing
End Sub
Ok, after some long hours, I figured it out, and got to the following solution.
My class module "MyOutlook" is:
Option Explicit
Public myOutlookApp As Outlook.Application
Public mySentFolder As Outlook.Folder
Public WithEvents myItems As Outlook.items
Private Sub Class_Initialize()
Set myOutlookApp = GetApplication("Outlook.Application")
Dim oNS As NameSpace
Set oNS = myOutlookApp.GetNamespace("MAPI")
Set mySentFolder = oNS.GetDefaultFolder(olFolderSentMail)
Set myItems = mySentFolder.items
End Sub
Private Sub myItems_ItemAdd(ByVal Item As Object)
Debug.Print "Got_EMAIL!!! Looking for subject = " & email_subject
'"e-mail_subject" is Public a string, assigned in another part of the program
If Item.Subject = email_subject Then
Item.SaveAs "C:\Users\640344\Desktop\mail_test.msg", olMSGUnicode
End If
End Sub
Where GetApplication is:
Function GetApplication(Class As String) As Object
'Handles creating/getting the instance of an application class
'If there exists one already (in my case, Outlook already open),
'it gets its name, else it creates one
Dim ret As Object
On Error Resume Next
Set ret = GetObject(, Class)
If Err.Number <> 0 Then
Set ret = CreateObject(Class)
If Class = "Outlook.Application" Then
'Outlook wasn't opened, so open it
ret.Session.GetDefaultFolder(olFolderInbox).Display
ret.ActiveExplorer.WindowState = olMaximized
ret.ActiveExplorer.WindowState = olMinimized
End If
End If
Set GetApplication = ret
On Error GoTo 0
End Function
Note that I added the 3 lines of code after 'Outlook wasn't opened, so open it because otherwise I would get an error. It's not a bad idea for my users that the program opens Outlook, anyway.
On the "regular" code part of my project, outside any procedure, I declare:
Public myOutlook As myOutlook
Then, on my project's "main" sub:
Set myOutlook = New myOutlook
'[...]
'Code where entire program runs
'[...]
Set myOutlook = Nothing
This way, myOutlook object (and its variables) "lives" the entire time the program (with its Navigation Forms) is running, and is waiting to trap _ItemAdd events on the default Sent Folder of Outlook.
Note that I look only for e-mails with subject equal to the email_subject string, because I don't want to save all sent e-mails, just the one sent by using the program, and I have code to assign my desired subject to that string.
Related
can someone advise what have I done wrong on here? It is not picking up the emails the way it should (i.e. automatically download the attachments into a folder). There is no error messages, but simply no action (I went F8 but would not notice any irregularities).
Private WithEvents Items 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")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "test123#gmail.com") And _
(Msg.Subject = "Test123") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Test\Test1\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Also, when I'm trying to F8 for errors, the VBA only goes through the first part of the code i.e. Private Sub Application_Startup(), I'm unable to test the other part {Private Sub Items_ItemAdd(ByVal item As Object)} cos the VBA simply denies going through it line by line (no error pop-ups or anything, it simply is not picking up the lines)
The problem is in the line
myAttachments.item(1).SaveAsFile attPath & Att
You are always picking attachment no 1, which might be something else than you think. Add a For Each around this, and you'll hopefully get some better results.
My guess is that your problem is this condition:
If (Msg.SenderName = "test123#gmail.com")
The MailItem.SenderName property returns the display name of the sender, which may not be the actual email address. You should be checking the MailItem.SenderEmailAddress property instead.
If the email you're trying to match is an Exchange address (ie, it's from someone in your office's Outlook account), the MailItem.SenderEmailAddress will return an incomprehensible string that you'll need to resolve to an actual email. In that case, you'd need to check the MailItem.Sender.GetExchangeUser().PrimarySmtpAddress property instead.
For that reason, I like to use an "emailMatches" function that checks both scenarios. Then your condition would be something like:
If emailMatches(Msg, "test123#company.com")
Here's the function I use:
Function emailMatches(mItem As Object, addressToMatch As String) As Boolean
Dim goAhead As Boolean
goAhead = False
If UCase(mItem.SenderEmailAddress) = UCase(addressToMatch) Then
goAhead = True
ElseIf Left(mItem.SenderEmailAddress, 5) = "/O=EX" Then
If UCase(mItem.Sender.GetExchangeUser().PrimarySmtpAddress) = UCase(addressToMatch) Then
goAhead = True
End If
End If
emailMatches = goAhead
End Function
I use the Application_ItemSend event to trigger actions on mails I send.
Under certain conditions the mail shall be moved to a new subfolder.
Since one can't move the mail before it is sent without jeopardizing the send, I copy the mail before sending and delete the original after.
Set myCopiedItem = objItem.Copy
myCopiedItem.Move olTempFolder
myCopiedItem.UnRead = False
myCopiedItem.SentOnBehalfOfName = olSession.CurrentUser
myCopiedItem.SendUsingAccount = olSession.Accounts(1)
'myCopiedItem.SenderName = olSession.CurrentUser
'myCopiedItem.SenderEmailAddress = olSession.CurrentUser.Address
objItem.DeleteAfterSubmit = True
I would like to have me as a sender on the copied mail.
I tried to set several different properties:
.SendOnBehalfOfName and .SendUsingAccount do not do what I am after.
.SenderName and .SenderEmailAddress showed to be "read only"
How can I avoid that the mail shows up in the folder without a sender?
Would this work for you:
Save the email in the Application_ItemSend event first:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Item.Save
MoveEmail Item, "\\Mailbox - Darren Bartrup-Cook\Inbox\Some Folder\Some Sub Folder"
End Sub
In a separate module (excuse MoveEmail being a function - originally it returned the EmailID of the moved email):
'----------------------------------------------------------------------------------
' Procedure : MoveEmail
' Author : Darren Bartrup-Cook
' Date : 03/07/2015
'-----------------------------------------------------------------------------------
Public Function MoveEmail(oItem As Object, sTo As String) As String
Dim oNameSpace As Outlook.NameSpace
Dim oDestinationFolder As Outlook.MAPIFolder
Set oNameSpace = Application.GetNamespace("MAPI")
Set oDestinationFolder = GetFolderPath(sTo)
oItem.Move oDestinationFolder
End Function
'----------------------------------------------------------------------------------
' Procedure : GetFolderPath
' Author : Diane Poremsky
' Original : http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
'-----------------------------------------------------------------------------------
Function GetFolderPath(ByVal FolderPath As String) As Outlook.MAPIFolder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Firstly, Move is a function, not a sub - it returns the newly created item. The original must be immediately discarded.
set myCopiedItem = myCopiedItem.Move(olTempFolder)
Secondly, sender related properties are set only after the message is sent and moved to the Sent Items folder. One solution is to wait until the Items.ItemAdd event fires on the Sent Items folder and make a copy then - the sender properties will be set by that time.
In theory, you can set a dozen or so PR_SENDER_* and PR_SENT_REPRESENTING_* MAPI properties, but if I remember my experiments correctly, MailItem.PropertyAccessor.SetProperty will not let you set sender related properties. If using Redemption is an option (I am its author), it allows to set the RDOMail.Sender and RDOMail.SentOnBehalfOf properties to an instance of an RDOAddressEntry object (such as that returned by RDOSession.CurrentUser).
So I have a program in access that lets the user select an outlook folder to import to a table. Which then can be selected from a combobox and transferred across to a form for use.
However I am having a problem with one of the values I am getting returned. SenderEmailAddress is not actually giving me an email address, for example this is what I get saved in my table.
I have removed names for privacy.
/O=COMPANY/OU=MAIL12/CN=RECIPIENTS/CN=FIRSTNAME.LASTNAME
Now of course, if I want to pass this value back over to outlook to reply to the email, I cannot use this.
Can anybody help me please?
Public Sub LoadEmails()
On Error Resume Next
'Outlook wasn't running, start it from code
If Started = False Then
Set olApp = New Outlook.Application '("Outlook.Application")
Started = True
End If
Set myNamespace = olApp.GetNamespace("MAPI")
Set objFolder = myNamespace.PickFolder
' if outlook is closed, it will display this error
If Err <> 0 Then
MsgBox "Outlook was closed. Please log out and log back in."
Started = False
Exit Sub
End If
'Exit if no folder picked.
If (objFolder Is Nothing) Then
MsgBox "No Folder Selected"
Started = False
Exit Sub
End If
Dim adoRS As Recordset
Dim intCounter As Integer
Set adoRS = CurrentDb.OpenRecordset("TBL_UserInbox") 'Open table Inbox
'Cycle through selected folder.
For intCounter = objFolder.Items.Count To 1 Step -1
With objFolder.Items(intCounter)
'Copy property value to corresponding fields
If .Class = olMail Then
adoRS.AddNew
adoRS("Subject") = .Subject
adoRS("TimeReceived") = .ReceivedTime
adoRS("Body") = .Body
adoRS("FromName") = .SenderEmailAddress '<<< Issue
adoRS("ToName") = .To
adoRS.Update
End If
End With
Next
MsgBox "Completed"
Started = False
End Sub
That is a perfectly valid email address of type EX (as opposed to SMTP). Check the MailItem.SenderEmailType property. If it is "SMTP", use the SenderEmailAddress property. If it is "EX", use MailItem.Sender.GetExchangeUser.PrimarySmtpAddress. Be prepared to handle nulls/exceptions.
I managed to find a nice little script that will forward emails to an external address becuase our exchange server is configured not to do that.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varEntryIDs
Dim objItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
Set myItem = objItem.Forward
myItem.Recipients.Add "mike.dumka#outlook.com"
myItem.Send
Next
End Sub
Works perfect. But now ... I would only like to do this if they are messages, not appointment updates or requests. I have no idea where to find this, or even what to look for. My VBA skills are from very long ago.
If you look at the screenshot, I think I have the MsgBox function in the right way, but could you verify?
Thanks,
Mike
You can either check the myItem.MessageClass property (it will be "IPM.Note" for the regular messages) or myItem.Class property - it will be 43 (olMail).
Just a little bit of conditional logic to ensure that you're only dealing with MailItem (since objItem is variant/object and may be another type of item like an AppointmentItem, etc.):
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
MsgBox "I'm working!", vbExclamation
Dim varEntryIDs
Dim objItem As Object
Dim myItem As MailItem
Dim i As Integer
varEntryIDs = Split(EntryIDCollection, ",")
For i = 0 To UBound(varEntryIDs)
Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
'## Check the item's TypeName and ONLY process if it's a MailItem:
If TypeName(objItem) = "MailItem" Then
Set myItem = objItem.Forward
myItem.Recipients.Add "mike.dumka#outlook.com"
myItem.Send
Else:
MsgBox "Type of item is: " & TypeName(objItem)
End If
Next
End Sub
Hello does anyone know how to create a VB Script that will add a rule in Outlook 2003 such that if I receive an email from user PersonA#mail.com it will forward that email to PersonB#mail.com.
I would also like to know if it possible to create a VB Script to remove the previously created rule.
I've done a little research and it seems possible to create a macro to do this, but I am completely lost as I am not familiar with the objects I need to be editing or have any sort of API.
Maybe I have to create a Macro to add the rules and this use a VB script to fire the Macro.
I would use straight VBA instead. The ItemAdd Event can be used to check your default Inbox for incoming messages and forward them. It is simple to edit the email addresses if you need to change the forwarding.
Ex:
Private WithEvents Items 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")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Goto ErrorHandler
Dim Msg As Outlook.MailItem
Dim newMsg As Outlook.MailItem
Dim recip As Outlook.Recipient
' *****************
' edit these to change forwarding rules
' *****************
Const INCOMING_EMAIL As String = "Persion#mail.com"
Const OUTGOING_EMAIL As String = "PersonB#mail.com"
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.SenderEmailAddress = INCOMING_EMAIL Then
Set newMsg = Msg.Forward
With newMsg
Set recip = .Recipients.Add OUTGOING_EMAIL
recip.Type = olTo
.Send
End With
' *****************
' perhaps a msgbox?
' MsgBox "Message forwarded", vbInformation
' *****************
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
This code should be placed in ThisOutlookSession module, then you must restart Outlook. If you need placement assistance see Where do I put my Outlook VBA code?