Checking for the presence of an attachment in outlook and display the data

Question

The code below is used to extract data of email from any folder in Outlook and display those data in an Excel file.

The data will display the sender name,sender email address, the subject and the time received.

But is there a way for the code to detect if the email have any attachment and will display yes or no for the presence of attachment or attachments in the email in another Excel column ?

Attached below is the code:

    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

Sure, check that olItem.Attachments.Count > 0

Answer 2

Simply use If olItem.Attachments.Count > 0 Then strColE = "YES"

Example

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

    ' check for attachment
    Dim strColE As String
    If olItem.Attachments.Count > 0 Then strColE = "YES"

    '==================== Get the Exchange address ====================

Then add xlSheet.Range("E" & rCount) = strColE ' Attament to

    '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

    xlSheet.Range("E" & rCount) = strColE ' Attament