I have the following code in ThisOutlookSession to save PDF attachments from emails when the emails go into a certain sub-folder in Outlook.
I thought I wasn't using the Initialize Handler correctly, but I have tried to change it around to no avail.
Public WithEvents myOlItem As Outlook.Items
Dim myOlApp As New Outlook.Application
Public Sub Initialize_handler()
Set myOlItem = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("WAM").Folders("UNPROCESSED").Items
End Sub
Private Sub myOlItem_ItemAdd(ByVal Item As Object)
Dim myOlMItem As Outlook.MailItem
Dim myOlAtts As Outlook.Attachments
Set myOlAtts = myOlMItem.Attachments
Call CallMyProcedure(Item)
End Sub
Sub CallMyProcedure()
Dim itms As Outlook.Items
Dim Itm As Object
' loop through default Inbox items
Set itms = myOlMItem 'Session.GetDefaultFolder(olFolderInbox).Folders("WAM").Folders("UNPROCESSED").Items
For Each Itm In itms
If TypeName(Itm) = "MailItem" Then
' your code is called here
savePDFtoDisk Itm
End If
Next Itm
Set objEmail = Nothing
End Sub
Sub savePDFtoDisk(Itm As Outlook.MailItem)
Dim dateFormat 'Dateiname mit Datum.
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
dateFormat = Format(Now, "mm_yyyy")
saveFolder = "\\marnv006\#marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\WAMS added to WAM Track\"
For Each objAtt In Itm.Attachments
If (InStr(1, objAtt.DisplayName, "WAM", vbTextCompare) > 0) Then
If LCase(Right(objAtt.FileName, 4)) = ".pdf" Then
objAtt.SaveAsFile saveFolder & objAtt.DisplayName
Set objAtt = Nothing
End If 'Nach PDF filtern.
End If
Next
End Sub
Replace the line Sub Initialize_handler() with Sub Application_Startup()
Or use this format
Sub Application_Startup()
Initialize_handler
End Sub
Edit 2015 11 16
The code is too convoluted. Redetermining the affected items than failing to pass them along.
Option Explicit
' In ThisOutlookSession
Private WithEvents myOlItem As Items
' Not needed if in Outlook
'Dim myOlApp As New Outlook.Application
'Public Sub Initialize_handler()
Private Sub application_Startup()
Dim myNS As Namespace
Dim myFolder As Folder
Set myNS = GetNamespace("MAPI")
Set myFolder = myNS.GetDefaultFolder(olFolderInbox)
Set myFolder = myFolder.Folders("WAM")
Set myFolder = myFolder.Folders("UNPROCESSED")
Set myOlItem = myFolder.Items
ExitRoutine:
Set myNS = Nothing
Set myFolder = Nothing
End Sub
' No need to redetermine items, ItemAdd already knows.
' Note itm to match the savePDFtoDisk code, not item.
Private Sub myOlItem_ItemAdd(ByVal Itm As Object)
'Sub savePDFtoDisk(Itm As Outlook.mailItem)
Dim dateFormat 'Dateiname mit Datum.
Dim objAtt As Outlook.attachment
Dim saveFolder As String
dateFormat = Format(Now, "mm_yyyy")
saveFolder = "\\marnv006\#marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\WAMS added to WAM Track\"
For Each objAtt In Itm.Attachments
If (InStr(1, objAtt.DisplayName, "WAM", vbTextCompare) > 0) Then
If LCase(Right(objAtt.Filename, 4)) = ".pdf" Then
objAtt.SaveAsFile saveFolder & objAtt.DisplayName
Set objAtt = Nothing
End If 'Nach PDF filtern.
End If
Next
End Sub
Related
I want the below code to run when a specific subject appears in an email.
Also to only run if that email has an attachment.
Outlook ignores the attachment part of the rule, and tries to run the code even if the attachment is not there (it seems to only care about the subject).
How do I incorporate a check for attachment in the code?
Public Sub SaveAttachmentsThenOpen(MItem As Outlook.MailItem)
Dim oMail As Variant
Dim oReply As Outlook.MailItem
Dim oItems As Outlook.Items
Dim Msg As Outlook.MailItem
Dim oAttachment As Outlook.Attachment
Dim StrBody As String
Dim oRep As MailItem
Dim sSaveFolder As String
Dim Att As String
Dim Attname As String
Dim sht As Object
Dim Rng As Range
Dim s As String
Dim myAttachments As Outlook.Attachments
Dim XLApp As Object
Dim XlWK As Object
Dim strPaste As Variant
Set oApp = New Outlook.Application
Set oNs = oApp.GetNamespace("MAPI")
Set XLApp = CreateObject("Excel.Application")
With XLApp
.Visible = True
.ScreenUpdating = True
.Workbooks.Open ("C:\Directory\data.xlsx")
.Workbooks.Open ("C:\Directory\WB.xlsb")
End With
Dim strText As String
strText = ".xls"
sSaveFolder = "C:\Directory\TPS_Reports\"
For Each oAttachment In MItem.Attachments
If InStr(1, oAttachment.FileName, strText) > 0 Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
Attname = oAttachment.FileName
Att = sSaveFolder & oAttachment.FileName
Exit For
End If
Next oAttachment
Set oAttachment = Nothing
XLApp.Workbooks.Open (Att)
XLApp.Visible = True
XLApp.Run ("WB.XLSB!MacroName")
Set sht = XLApp.Workbooks(Attname).ActiveSheet
Set Rng = sht.UsedRange
s = "<table border=1 bordercolor=black cellspacing=0>"
For rw = Rng.Row To Rng.Rows.Count
s = s & "<tr>"
For col = Rng.Column To Rng.Columns.Count
s = s & "<td>" & sht.Cells(rw, col) & "</td>"
Next
s = s & "</tr>"
Next
s = s & "</table>"
Set oRep = MItem.ReplyAll
With oRep
StrBody = "Hello"
.HTMLBody = s
.Send
End With
With XLApp
.DisplayAlerts = False
End With
XLApp.Workbooks(Attname).Save
XLApp.Quit
With XLApp
.DisplayAlerts = True
End With
End Sub
Try waiting for the mail to be in the inbox before checking for the attachment.
Code for the ThisOutlookSession module
Restart Outlook or run Application_Startup manually.
Private WithEvents myItems As Items
Private Sub Application_Startup()
Dim myInbox As folder
Set myInbox = Session.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
End Sub
Private Sub myItems_ItemAdd(ByVal Item As Object)
If TypeOf Item Is mailItem Then
If Item.Attachments.Count > 0 Then
SaveAttachmentsThenOpen Item
End If
End If
End Sub
Private Sub test()
myItems_ItemAdd ActiveInspector.currentItem
End Sub
I pieced this together for saving all Excel attachments from incoming mail to a local drive folder.
It is in the ThisOutlookSession module and I restarted Outlook.
When I send a test email meeting the criteria in the If statements, I receive >"Error 438: Object doesn't support this property or method".
I can't figure out which object doesn't support which property or method.
It is at least running up to my If statements because this only happens to emails that meet the criteria.
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 i As Integer
Dim strFolder As String
Dim mySaveName As String
Dim myExt As String
Dim OlMail As Outlook.MailItem
strFolder = "D:\Scripts\VendorProductivity\Daily files"
If TypeName(Item) = "MailItem" Then
If Item.Subject Like "*Report*" Then
If Item.Recipient = "Jane Doe" Then
If Item.Attachments.Count > 0 Then
'loop through all attachments
For i = 1 To Item.Attachments.Count
mySaveName = Item.Attachments.Item(i).FileName
myExt = Split(mySaveName, ".")(1)
'Only save files with named extensions
Select Case myExt
Case "xls", "xlsm", "xlsx"
mySaveName = strFolder & "\" & mySaveName
Item.Attachments.Item(i).SaveAsFile mySaveName
Case Else
'do nothing
End Select
Next
Item.Delete
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
MailItem does not expose a property named Recipient (singular). It exposes a property named Recipients (plural), but is is not a string property - it is a collection of Recipient objects, which expose Name and Address properties among others.
Did you mean to use the SenderName property instead?
I am trying to save the attachments of an email to my desktop. A sub calls another sub using the Item(1) as input. So far I have this, it gives error when calling the sub saveAttachtoDisk. It gives the error shown on the picture.
Sub Call_saveAttachtoDisk()
Dim objSelection As Outlook.Selection
Dim objMsg As Object 'Object
Set objSelection = ActiveExplorer.Selection
Set objMsg = objSelection.Item(1)
saveAttachtoDisk (objMsg)
End Sub
Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim i As Integer
i = 0
saveFolder = "C:\Users\peet\Desktop"
For Each objAtt In itm.Attachments
i = i + 1
objAtt.SaveAsFile saveFolder & "\name" & i & ".pdf"
Set objAtt = Nothing
Next
End Sub
Found the solution.
Need to add Call before calling the sub
Call saveAttachtoDisk (objMsg)
Simply remove the parenthesis ()
Exmple
saveAttachtoDisk objMsg
I've been playing around with the below code in an attempt to save files which we receive daily in Outlook. The code seems to run fine, however, when I go to check the destination folder there are no attachments saved.
How can I modify the code to save the attachments to the specified folder?
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 = "made-up-email#some_domain.com") And _
(Msg.Subject = "Test") 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 = "T:\London File3 Group\Client Reporting\Test"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
End Sub
This code should work, something you may not have done is added this to the ThisOutlookSession object. Don't add to a standard module.
Private WithEvents InboxItems As Outlook.Items
Const attPath As String = "T:\London File3 Group\Client Reporting\Test\"
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
Set InboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
Dim Msg As Outlook.MailItem: Set Msg = Item
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Filename As String
If Not TypeName(Msg) = "MailItem" Then Exit Sub
If (Msg.SenderName = "made-up-email#some_domain.com") And (Msg.Subject = "Test") And (Msg.Attachments.Count >= 1) Then
Set myAttachments = Item.Attachments
Filename = myAttachments.Item(1).DisplayName
myAttachments.Item(1).SaveAsFile attPath & Filename
Msg.UnRead = False
End If
End Sub
So, the goal is that when I receive an email from a customer, containing the desired attachment, save the attachment to a location of my choosing.
This is my new code, it compiles but doesn't output the file?
Thanks in advance.
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 Application_NewMail()
Dim oInbox As MAPIFolder
Dim oItem As MailItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = oItem
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Name Of Person") And _
(Msg.Subject = "Subject to Find") 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:\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
When you open the VBA window, you will see the object called "ThisOutlookSession", which is where you place the code.
This event is triggered automatically upon reception of a new email received:
Private Sub Application_NewMail()
Dim oInbox As MAPIFolder
Dim oItem As MailItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast
//MsgBox oItem.To
//Etcetera
End Sub
About your edit, I didn't really investigate why it didn't work, but you can use this, which I tested:
Dim atmt As Outlook.Attachment
Dim Att As String
Const attPath As String = "U:\"
For Each atmt In Msg.Attachments
Att = atmt.DisplayName
atmt.SaveAsFile attPath & Att
Next
Note that it may seem as if you didn't save the file, because you cannot use 'Date modified' in WinExplorer to show the latest saved attachment (I noticed just now). But you can look it up alphabetically.