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
Related
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 want to download 4 unique csv files that I receive daily. So I need to download these 4 automatically. As of now, I can download all csv files but I can't limit it to only today's date.
This is my current code.
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Desktop\Automatic Outlook Downloads"
For Each object_attachment In item.Attachments
If InStr(object_attachment.DisplayName, ".csv") Then
'If Int(object_attachment.ReceivedTime) = Date Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
'End If
Next
End Sub
I was able to answer my own question. Below is my modified code.
Public Sub SaveAutoAttach(item As Outlook.MailItem)
Dim olApp As Object
Dim olNS As Object
Dim myDate As Date
Dim olItems As Object
Dim olItem As Object
Dim olAttach As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If
Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items
For Each olItem In olItems
If olItem.ReceivedTime > Date Then
On Error GoTo Finished
Set olAttach = olItem.Attachments.item(1)
Err.Clear: On Error GoTo 0
If Not olAttach Is Nothing Then
If olAttach.FileName Like "*.csv" Then
On Error GoTo Finished
olAttach.SaveAsFile "C:\Desktop\Automatic Outlook Downloads" & "\" & olAttach.FileName
Set olAttach = Nothing
Set olItem = Nothing
End If
End If
End If
Next
Ever day at 12 am there is an automatic email with an excel attachment from a vendor service with a specific subject. I am using rules and code to attempt to save the attachment and insert the information into a database I have created upon being received in the inbox.
I have tried code that I have found online however I don't know if doesn't work because of some network/ security setting my company has or if its he code it self.
Rule:
CODE:
Public Sub CribMaster2Database(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\"
If olItem.Subject = "Test" Then
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End If
End Sub
Add code to the ThisOutlookSession to watch your folder for arrivals.
CribMaster_ItemAdd fires whenever something arrives in your watched folder.
At the very top of the module:
Dim WithEvents CribMaster As Items
Const SAVE_PATH As String = "c:\temp\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = GetNamespace("MAPI")
'Change `holi4683` to the name of your account
'(should be visible just above your inbox).
Set CribMaster = ns.Folders.Item("holi4683") _
.Folders.Item("Inbox").Items
End Sub
Sub CribMaster_ItemAdd(ByVal Item As Object)
Dim olAtt As Attachment
Dim i As Integer
With Item
For i = 1 To .Attachments.Count
Set olAtt = .Attachments(i)
olAtt.SaveAsFile SAVE_PATH & olAtt.DisplayName
.UnRead = False
DoEvents
Next i
End With
Set olAtt = Nothing
End Sub
I'd usually use a rule to move the emails to a subfolder and watch that folder - means I don't have to worry about meeting invites, etc.
To do this you'd change your watched folder like this:
Set CribMaster = ns.Folders.Item("holi4683") _
.Folders.Item("Inbox") _
.Folders.Item("SubFolder").Items
Restart Outlook for the code to work, or manually run the Application_Startup() procedure.
I have full access to two shared emails on my account. I would like to run a macro on one of the shared emails inbox that saves the attachments to the hard drive. I don't want the macro to run on all items in the inbox but only the ones selected/highlighted. I am unable to get the code below to work. Can I get some advice on how to make my code work?
Public Sub saveAttachtoDisk ()
Dim objAtt As Outlook.Attachment
Dim dateFormat
dateFormat = Format(Now, "yyyy-mm-dd H-mm")
Dim saveFolder As String
Dim itm As Outlook.MailItem
Dim objNS As Outlook.NameSpace
Set objNS = olApp.GetNamespace("MAPI")
Dim myRecipient As Outlook.Recipient
Set myRecipient = objNS.CreateRecipient("invoices#domain.com")
myRecipient.Resolve
Set inbox = objNS.GetSharedDefaultFolder(myRecipient, olFolderInbox)
saveFolder = "c:\temp\"
For Each itm In ActiveExplorer.Selection
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Set objAtt = Nothing
Next objAtt
Next itm
End Sub
The code looks good, I don't see anything strange. But most probably you need to correct the file path (remove the double backslash):
objAtt.SaveAsFile saveFolder & dateFormat & objAtt.DisplayName
Do you get any error in the code? Did you try to specify another file path?
Be aware, the C: drive requires admin privileges for writing on systems with UAC enabled.
Option Explicit ' <-----
Public Sub saveAttachtoDisk()
...
End Sub
Compile error:
Variable not defined
olApp is not defined:
Set objNS = olApp.GetNamespace("MAPI")
If the code is in Outlook:
Set objNS = Application.GetNamespace("MAPI")
If not in Outlook:
Dim olApp As Outlook.Application
To automatically generate Option Explicit at the top of new modules:
In the VB editor. Tools menu | Options
Check "Require Variable Declaration"
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