Sleeper: Download .xlsm from outlook

[samuelimtech]

Hi all,

first of all thanks for any help.

I have the following code and for some reason it keeps failing at the next (just above the commented out error handler).
I cant see any issues in my logic and quite frankly its frustrating now. can anyone see where im going wrong. i have played around with error handlers in various positions but cant suss it out.

[Sub SaveAttachments()
    Dim myOlapp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolder As Outlook.MAPIFolder
    Dim myItem As Outlook.MailItem
    Dim myAttachment As Outlook.Attachment
    Dim i As Long
Set myOlapp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlapp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myFolder = myFolder.Folders("TS")
For Each myItem In myFolder.Items
        If myItem.Attachments.Count <> 0 Then
        i = 1
            For Each myAttachment In myItem.Attachments
'On Error GoTo Myerrorhandler
'MsgBox Right(myItem.Attachments.Item(i).FileName, 15)
                If Right(myItem.Attachments.Item(i).FileName, 5) = ".xlsm" Then
                myAttachment.SaveAsFile "T:\Inter Urban\Consultancy Services\Timesheets\Templates\Access\Download\" & myItem.Attachments.Item(i).FileName
                Else
                End If
                  i = i + 1
            Next
        End If
    Next
'Myerrorhandler:
    Exit Sub
    Resume Next
End Sub

[mancubus]

try...

myPath = "T:\Inter Urban\Consultancy Services\Timesheets\Templates\Access\Download\"

For Each myAttachment In myItem.Attachments
    If Right(myAttachment.FileName, 5) = ".xlsm" Then
        myAttachment.SaveAsFile myPath & myAttachment.FileName
    End If
Next

[samuelimtech]

Hi thanks for the response but this hasnt helped, im still getting the same type mismatch erro message, whats wierd is if i just f8 it on then the macro works completely fine to the end??

[mancubus]

this is a working example that i use regularly.

Sub Save_Mail_Attach_XLSM_Files()
    Dim MailItem As Object, Att As Object
    Dim fPath As String
    Dim calc As Long
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    fPath = "H:\MyFiles\"
    With CreateObject("Outlook.Application")
        With .GetNamespace("MAPI")
            With .Folders("Mailbox - Name Surname (Department Name)")
                With .Folders("Inbox")
                    On Error Resume Next
                    For Each MailItem In .Items
                        With MailItem
                            For Each Att In .Attachments
                                If CreateObject("Scripting.FileSystemObject").GetExtensionName(Att.FileName) = "xlsm" Then
                                    Att.SaveAsFile fPath & Att.FileName
                                End If
                            Next
                            On Error Goto 0
                        End With
                    Next
                End With
            End With
        End With
    End With
    
    With Application
        .EnableEvents = True
        .Calculation = calc
    End With
End Sub

for my case Folders("Mailbox - Name Surname (Department Name)") is the top folder that contain Inbox, etc...

[snb]

Sub M_snb()
       For Each it in CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("TS").Items
             For each at in it.Attachments
        If Right(at.FileName, 5) = ".xlsm" Then at.SaveAsFile "T:\Inter Urban\Consultancy  Services\Timesheets\Templates\Access\Download\" &  at.FileName
     next
   next
End Sub

NB. I can't check the structure of your Outlook folders
I can't check the validity of your folderstucture on drive T