Erhalten Sie Anhänge Dateinamen aus E-Mails VBA

Question

Ich habe einen Ordner, der E-Mails mit Anhängen und ohne Anhänge hat. Ich habe den Code zum Extrahieren der Anhänge Namen, aber wenn eine E-Mail keine Anhänge hat, wird der Code gestoppt. Jede Hilfe ist willkommen, danke.

von jimmypena

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 

Mein 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 <> "" 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 

Answer 1

bearbeitet

Set a = myitem1.Attachments 
MsgBox a.Count 

For j = 1 To myitem1.Attachments.Count 
    MsgBox myitem1.Attachments.Item(j).DisplayName ' or .Filename 
Next j 

wie über Ihre editierten Frage, ersetzen Sie das folgende Snippet

  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 

mit:

 Dim a As Attachment 
     For Each a In olkMsg.Attachments 
      excWks.Cells(intRow, 1) = a.FileName 
      'excWks.Cells(intRow, 2) = a.SenderEmailAddress 
     Next a 

, die Sie in geeigneter Weise wie für den intRow Index behandeln müssen.

, wenn Sie nur in den ersten Befestigungs interessiert sind, dann können Sie den gesamten letzten Code mit diesem ersetzen:

excWks.Cells(intRow, 1) = olkMsg.Attachments.Item(1).FileName 

während, wenn Sie in allen Anhängen interessiert sind, dann werden Sie haben zu Ihrem Blatt Bericht zu überdenken Struktur