title: Get attachments file names from emails vba
body: <p>I have a folder that has emails with attachments and without attachments. i have the code for extracting the attachments names but if an email doesn't have attachments the code will stop. Any help is welcomed, thank you.</p>
  
  <p>by <a href="https://stackoverflow.com/users/190829/jimmypena">jimmypena</a></p>
  
  <pre><code>Private Sub CommandButton2_Click()
  
  Dim a As Attachments
  Dim myitem As Folder
  Dim myitem1 As MailItem
  Dim j As Long
  Dim i As Integer
  
  Set myitem = Session.GetDefaultFolder(olFolderDrafts)
  
  For i = 1 To myitem.Items.Count
    If myitem.Items(i) = test1 Then
      Set myitem1 = myitem.Items(i)
      Set a = myitem1.Attachments
  
      MsgBox a.Count
  
      ' added this code
      For j = 1 To myitem1.Attachments.Count
        MsgBox myitem1.Attachments.Item(i).DisplayName ' or .Filename
      Next j
  
    End If
  Next i
  End Sub
  </code></pre>
  
  <p>My code:</p>
  
  <pre><code>Sub EXPORT()
  
      Const FOLDER_PATH = "\\Mailbox\Inbox\emails from them"
      Dim olkMsg As Object, _
          olkFld As Object, _
          excApp As Object, _
          excWkb As Object, _
          excWks As Object, _
          intRow As Integer, _
          intCnt As Integer, _
          strFileName As String, _
          arrCells As Variant
          strFileName = "C:\EXPORT"
          If strFileName &lt;&gt; "" Then
          Set excApp = CreateObject("Excel.Application")
          Set excWkb = excApp.Workbooks.Add()
          Set excWks = excWkb.ActiveSheet
          excApp.DisplayAlerts = False
          With excWks
  
              .Cells(1, 1) = "ATTACH NAMES"
              .Cells(1, 2) = "SENDER"
              .Cells(1, 3) = "NR SUBJECT"
              .Cells(1, 4) = "CATEGORIES"
  
          End With
          intRow = 2
          Set olkFld = OpenOutlookFolder(FOLDER_PATH)
          For Each olkMsg In olkFld.Items
              If olkMsg.Class = olMail Then
                  arrCells = Split(GetCells(olkMsg.HTMLBody), Chr(255))
  
  
                      Dim Reg1 As RegExp
                      Dim M1 As MatchCollection
                      Dim M As match
                      Set Reg1 = New RegExp
                          With Reg1
                          .Pattern = "\s*[-]+\s*(\w*)\s*(\w*)"
                          .Global = True
                          End With
                             Set M1 = Reg1.Execute(olkMsg.Subject)
                             For Each M In M1
                  excWks.Cells(intRow, 3) = M
                             Next
  
                  Dim a As Attachments
                  Set a = olkMsg.Attachments
                  If Not a Is Nothing Then
  
  
                  excWks.Cells(intRow, 1) = olkMsg.Attachment.Filename
                  'excWks.Cells(intRow, 2) = olkMsg.SenderEmailAddress
                  End If
  
                  excWks.Cells(intRow, 2) = olkMsg.sender.GetExchangeUser.PrimarySmtpAddress
                  excWks.Cells(intRow, 4) = olkMsg.Categories
  
                  intRow = intRow + 1
                  intCnt = intCnt + 1
              End If
          Next
          Set olkMsg = Nothing
          excWkb.SaveAs strFileName, 52
          excWkb.Close
      End If
      Set olkFld = Nothing
      Set excWks = Nothing
      Set excWkb = Nothing
      Set excApp = Nothing
      MsgBox "Ta dam! "
  End Sub
  </code></pre>