Save Outlook Attachment/Move e-mail

[RonRepp]

Hi all:

I'm working on a procedure that (supposedly) saves the attachments to a folder on the network, and then moves the e-mail to a folder in Outlook.

Every time I get one part working, another stops, and I cannot figure out why.

Sub SaveAttachments()
  On Error GoTo SaveAttachments_err
  
    Dim NSpace As Outlook.NameSpace
    Dim MailInbox As Outlook.Folder
    Dim DestFolder As Outlook.Folder
    Dim FinalFolder As Outlook.Folder
    Dim MailItems As Outlook.Items
    Dim MailItm As MailItem
    Dim Atmt As Attachment
    Dim fldrOLName As String, fldrOL As String
    Dim i As Integer, Count As Integer
    Dim FName As String
    Const FileName As String = "L:\Programming\OutlookApp\"

    Set NSpace = Application.GetNamespace("MAPI")
    Set MailInbox = NSpace.GetDefaultFolder(olFolderInbox)
    Set MailItems = MailInbox.Items
    Set DestFolder = MailInbox.Folders("AA")
    
  i = 0
  If MailInbox.Items.Count = 0 Then Exit Sub
  
  For Each MailItm In MailInbox.Items
      
      If MailItm.Attachments.Count > 0 Then
        For Count = MailItm.Attachments.Count To 1 Step -1
          Set Atmt = MailItm.Attachments.Item(Count)
          
            [COLOR=blue]Select Case MailItm.SenderMailItmAddress
                Case "RonRepp@comcast.net"
                    fldrOLName = "RonComcast"[/color]
                
                Case "RonRepp@SBCGlobal.net"
                    fldrOLName = "RonSBC"
                
                Case "Ron@RepProductions.net"
                    fldrOLName = "RonRepProductions"
            
            End Select
              
              FName = FileName & fldrOLName & "\"
              Debug.Print FName
            Atmt.SaveAsFile (FName & Atmt.FileName)
            'Atmt.Delete
            i = i + 1
          
        Next Count
        MailItm.Save
        
        Set FinalFolder = DestFolder.Folders(fldrOLName)
        MailItm.Move FinalFolder
        
      End If
  
  Next MailItm
  If i > 0 Then
    MsgBox "  " & i & " attached files were found." _
       & vbCrLf & "They have been copied to your work folder." _
       & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
  Else
    MsgBox "No attached files were found in your mail.", vbInformation, _
    "Finished!"
  End If
SaveAttachments_exit:
 Set Atmt = Nothing
 Set MailItm = Nothing
 Exit Sub
SaveAttachments_err:
 MsgBox "An unexpected error has occurred." _
      & vbCrLf & "Please note and report the following information." _
      & vbCrLf & "Macro Name: SaveAttachments" _
      & vbCrLf & "Error Number: " & Err.Number _
      & vbCrLf & "Error Description: " & Err.Description _
      , vbCritical, "Error!"
 Resume SaveAttachments_exit
End Sub

I highlighted where it's erring now.

Thanks,


Ron Repp

If gray hair is a sign of wisdom, then I'm a genius.

My newest novel: Wooden Warriors

http://www.repproductions.net