excel - 检查 Outlook 中是否存在附件并显示数据

Question

下面的代码用于从 Outlook 中的任何文件夹中提取电子邮件数据，并将这些数据显示在 Excel 文件中。

数据将显示发件人姓名、发件人电子邮件地址、主题和收到时间。

但是有没有办法让代码检测电子邮件是否有任何附件，并在另一个 Excel 列中显示是否存在电子邮件中的附件或附件？

下面附上代码:

    Option Explicit
 Sub ExportDataToExcel()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim olItem As Outlook.MailItem
 Dim obj As Object
 Dim strColA, strColB, strColC, strColD As String


Dim currentExplorer As Outlook.NameSpace
Dim Selection As Outlook.MAPIFolder
' Get Excel set up
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0

'======== Open a specific workbook to input the data ============
'the path of the workbook under the windows user account
enviro = CStr(Environ("USERPROFILE"))
 strPath = enviro & "\Desktop\New folder\OutlookItems.xlsx"
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")
'================== End Specific workbook ====================

'=================== Use New Workbook ========================
'Set xlWB = xlApp.Workbooks.Add
'Set xlSheet = xlWB.Sheets("Sheet1")
'================== end use new workbook =====================

' Add column names
  xlSheet.Range("A1") = "SENDER"
  xlSheet.Range("B1") = "SENDER ADDRESS"
  xlSheet.Range("C1") = "MESSAGE SUBJECT"
  xlSheet.Range("D1") = "RECEIVED TIME"
  xlSheet.Range("A1").Interior.Color = RGB(0, 255, 255)
  xlSheet.Range("B1").Interior.Color = RGB(0, 255, 255)
  xlSheet.Range("C1").Interior.Color = RGB(0, 255, 255)
  xlSheet.Range("D1").Interior.Color = RGB(0, 255, 255)


' Process the message record

  On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.GetNamespace("MAPI")
Set Selection = currentExplorer.PickFolder
  For Each obj In Selection.Items

    Set olItem = obj

 'collect the fields
    strColA = olItem.SenderName
    strColB = olItem.SenderEmailAddress
    strColC = olItem.Subject
    strColD = olItem.ReceivedTime

'================== Get all recipient addresses ===================
' instead of To names
Dim strRecipients As String
Dim Recipient As Outlook.Recipient
For Each Recipient In olItem.Recipients
 strRecipients = Recipient.Address & "; " & strRecipients
 Next Recipient



'================== end all recipients addresses ==================

'==================== Get the Exchange address ====================
' if not using Exchange, this block can be removed
 Dim olEU As Outlook.ExchangeUser
 Dim oEDL As Outlook.ExchangeDistributionList
 Dim recip As Outlook.Recipient
 Set recip = Application.Session.CreateRecipient(strColB)

If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
    Select Case recip.AddressEntry.AddressEntryUserType
       Case OlAddressEntryUserType.olExchangeUserAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
             strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olOutlookContactAddressEntry
         Set olEU = recip.AddressEntry.GetExchangeUser
         If Not (olEU Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
       Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
         Set oEDL = recip.AddressEntry.GetExchangeDistributionList
         If Not (oEDL Is Nothing) Then
            strColB = olEU.PrimarySmtpAddress
         End If
     End Select
End If
' ==================== End Exchange section =====================

'write them in the excel sheet
  xlSheet.Range("A" & rCount) = strColA ' sender name
  xlSheet.Range("B" & rCount) = strColB ' sender address
  xlSheet.Range("C" & rCount) = strColC ' message subject
  xlSheet.Range("D" & rCount) = strColD ' recieved time

'Next row
  rCount = rCount + 1

' size the cells
    xlSheet.Columns("A:D").EntireColumn.AutoFit
    xlSheet.Columns("C:C").ColumnWidth = 100
    xlSheet.Range("A2").Select
    xlSheet.Columns("A:D").VerticalAlignment = xlTop

 Next
 xlApp.Visible = True

' to save but not close
'xlWB.Save

' to save and close
'     xlWB.Close 1
'     If bXStarted Then
'         xlApp.Quit
'     End If
' end save and close

     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlSheet = Nothing
     Set xlWB = Nothing
     Set xlApp = Nothing
 End Sub

Answer 1

当然，检查 olItem.Attachments.Count > 0