Hi. I'm appealing to experience here.
I have a workbook that opens as a scheduled task. Upon doing so, a Workbook_Open subroutine is called up, which calls up smaller subroutines to scan through Outlook for emails in different areas, saving attachments in various places on my computer.
The code for each of the smaller subroutines is pretty much the same. All that changes is the area in which the VBA searches for mail, the sender's address and subject line, and the destination for any attachments.
Suddenly, whenever the code comes across an 'Object.SaveasFile' line, it fails with a 'Cannot Save the Attachment' error. The code hasn't changed. The filepaths and other parameters haven't changed. If I call up the smaller subroutines indiividually they all fail at the same point. Suddenly, for some reason, the code will no longer save attachments.
Has anyone ever come across a situation where this suddenly occurs?
An example of one of these subroutines (there are a couple of user-defined functions along the way, but they seem to be working fine):
I have a workbook that opens as a scheduled task. Upon doing so, a Workbook_Open subroutine is called up, which calls up smaller subroutines to scan through Outlook for emails in different areas, saving attachments in various places on my computer.
The code for each of the smaller subroutines is pretty much the same. All that changes is the area in which the VBA searches for mail, the sender's address and subject line, and the destination for any attachments.
Suddenly, whenever the code comes across an 'Object.SaveasFile' line, it fails with a 'Cannot Save the Attachment' error. The code hasn't changed. The filepaths and other parameters haven't changed. If I call up the smaller subroutines indiividually they all fail at the same point. Suddenly, for some reason, the code will no longer save attachments.
Has anyone ever come across a situation where this suddenly occurs?
An example of one of these subroutines (there are a couple of user-defined functions along the way, but they seem to be working fine):
Code:
Sub ReportsManager()
Application.DisplayAlerts = False
' This Outlook macro checks the Reports folder for messages
' Declare variables
Dim olApp As Outlook.Application
Dim ns As Namespace
Dim MessagesFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim NotificationMail As MailItem
Dim SenderEmailAddress As String
Dim ForwardMessage As MailItem
Dim DeletedItem As Boolean
Dim StockReportLocation As String
' set locations for saving files to
StockReportLocation = "filepath"
to the outlook app and set your objects
Set olApp = New Outlook.Application
Set ns = GetNamespace("MAPI")
Set MessagesFolder = GetFolder("\\Public Folders - automator@email.com\All Public Folders\Operations\Reports")
' Check mailbox for messages and exit of none found
If MessagesFolder.Items.Count = 0 Then
If olApp.Session.CurrentUser <> "Automator" Then
MsgBox "There are no messages in the Reports Folder.", vbInformation, _
"ReportsCheck " & VersionNumber
End If
Exit Sub
End If
' Check each message in the messages folder, move it, save it or delete it etc
LoopThrough:
DeletedItem = False
For Each Item In MessagesFolder.Items
'to make sure it only bleats once per email about checking addresses
SenderEmailAddress = Item.SenderEmailAddress
' stock message
If SenderEmailAddress = "no-reply@email.com" And Item.Subject = "Insert Subject Line Here" Then
For Each Atmt In Item.Attachments
FileName = StockReportLocation & "FileName" & "-" & Format(Item.SentOn, "yymmdd-hhnn") & Right(Atmt.FileName, 4)
Atmt.SaveAsFile FileName
Next Atmt
Item.Delete
DeletedItem = True
'Old outtake messages
ElseIf InStr(Item.Subject, "Insert Subject Line Here") And Item.SentOn < Date - 365 Then
Item.Delete
DeletedItem = True
'Old intake messages
ElseIf InStr(Item.Subject, "Insert Subject Line Here") And Item.SentOn < Date - 365 Then
Item.Delete
DeletedItem = True
'Old release messages
ElseIf InStr(Item.Subject, "Insert Subject Line Here") And Item.SentOn < Date - 365 Then
Item.Delete
DeletedItem = True
'out of office autoreplies
ElseIf Left(Item.Subject, 24) = "Out of Office AutoReply:" Then
Item.Delete
DeletedItem = True
End If
Next Item
'run the check again if you've deleted a file (otherwise it misses items)
If DeletedItem = True Then
GoTo LoopThrough:
End If
' Show summary message
If MessagesFolder.Items.Count > 0 Then
If olApp.Session.CurrentUser <> "Automator" Then
MsgBox "Reports checked. " & MessagesFolder.Items.Count & " emails remaining to deal with.", vbInformation, "AutomatorEmailCheck " & VersionNumber
MessagesFolder.Display
End If
Else
If olApp.Session.CurrentUser <> "Automator" Then
MsgBox "All done.",
End If
End If
Application.DisplayAlerts = True
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
End Sub
Last edited by a moderator:
