Question

我有一个包含附件和没有附件的电子邮件的文件夹。我有提取附件名称的代码，但如果电子邮件没有附件，代码将停止。欢迎任何帮助，谢谢。

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

我的代码：

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

<强>编辑

Set a = myitem1.Attachments
MsgBox a.Count

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

关于您编辑过的问题，请替换以下代码段

            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

使用：

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

您必须对intRow索引进行适当处理。

如果您只对第一个附件感兴趣，那么您可以用以下代码替换整个最后一个代码：

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

如果您对所有附件感兴趣，那么您将不得不重新考虑您的工作表报告结构

从电子邮件vba获取附件文件名

1 个答案: