Question : Outlook VB Code Quit Working

This code worked great until yesterday. Each day it locates an email with a specific attachment file name and saves the attachment in a folder. If there is an error or if Outlook cannot be accessed, there is an error "Cannot get into Outlook" and I am now getting this error. I run this code from within a MS Access 2003 function module. This code ran fine Friday, butnow today it is having an issue. I have no idea where to look...

Code Snippet:

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:



Function AttachmentsMove()
 
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
    On Error GoTo GetAttachments_err
' Declare variables
    Dim myolApp As New Outlook.Application
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim I As Integer
    Dim Reports As MAPIFolder
    Dim blnFound As Boolean
    Set myolApp = CreateObject("Outlook.Application")
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set Reports = ns.Folders("Personal Folders").Folders("Call_Reports")
    I = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
               "Nothing Found"
        Exit Function
    End If
    blnFound = False
' Check each message for attachments
    For Each Item In Inbox.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
        ' This path must exist! Change folder name as necessary.
            If Atmt.FileName = "Calls by Extension Master List.xls" Then
            blnFound = True
            Atmt.SaveAsFile "P:\databases\downloads\extensionstats\" & Atmt.FileName
            I = I + 1
            Item.Move Reports
            End If
            
         Next Atmt
         
         If I = 1 Then
         
         Exit For
         End If
    
    Next Item
    If Not blnFound Then
        MsgBox "Master Call List Summary email not found in Inbox"
        ' if you want the code to stop right here,
        Stop
        ' if you want the code to stop running,
        'End
        End If
   
 
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Function
' Handle errors
GetAttachments_err:
    MsgBox "Couldn't get into Outlook."
        Stop
        '& vbCrLf & "Please note and report the following information." _
        '& vbCrLf & "Macro Name: GetAttachments" _
        '& vbCrLf & "Error Number: " & Err.Number _
        '& vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume GetAttachments_exit
End Function

Open in New Window

Select All

Answer : Outlook VB Code Quit Working

Try checking for an embedded item, i.e. replace~:

For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
If Atmt.FileName Like "Call List*" Then
blnFound = True
Atmt.SaveAsFile "P:\Sales_Dept\Reports\extensionstats\Reps\" & Atmt.FileName
I = I + 1

End If

Next Atmt

With the snippet

Chris

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:



        For Each atmt In Item.Attachments
        ' This path must exist! Change folder name as necessary.
            If atmt.Type <> olole Then
                If atmt.Filename Like "Call List*" Then
                    blnFound = True
                    atmt.SaveAsFile "P:\Sales_Dept\Reports\extensionstats\Reps\" & atmt.Filename
                    I = I + 1
                End If
            End If
         Next atmt

Open in New Window

Select All