title: Automate Attachment Save
body: <p>So, the goal is that when I receive an email from a customer, containing the desired attachment, save the attachment to a location of my choosing.</p>
  
  <p><strong>This is my new code, it compiles but doesn't output the file?</strong></p>
  
  <p>Thanks in advance.</p>
  
  <pre><code>Private WithEvents Items As Outlook.Items
  
  Private Sub Application_Startup()
      Dim olApp As Outlook.Application
      Dim objNS As Outlook.NameSpace
      Set olApp = Outlook.Application
      Set objNS = olApp.GetNamespace("MAPI")
      Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
  End Sub
  
  Private Sub Application_NewMail()
  
  Dim oInbox As MAPIFolder
  Dim oItem As MailItem
  
  Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
  Set oItem = oInbox.Items.GetLast
  
  'Only act if it's a MailItem
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then
      Set Msg = oItem
  
      'Change variables to match need. Comment or delete any part unnecessary.
      If (Msg.SenderName = "Name Of Person") And _
          (Msg.Subject = "Subject to Find") And _
          (Msg.Attachments.Count &gt;= 1) Then
  
          'Set folder to save in.
          Dim olDestFldr As Outlook.MAPIFolder
          Dim myAttachments As Outlook.Attachments
          Dim Att As String
  
          'location to save in.  Can be root drive or mapped network drive.
          Const attPath As String = "C:\"
  
          ' save attachment
          Set myAttachments = item.Attachments
          Att = myAttachments.item(1).DisplayName
          myAttachments.item(1).SaveAsFile attPath &amp; Att
  
          ' mark as read
         Msg.UnRead = False
      End If
  End If
  
  ProgramExit:
      Exit Sub
  
  ErrorHandler:
      MsgBox Err.Number &amp; " - " &amp; Err.Description
      Resume ProgramExit
  End Sub
  </code></pre>