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

Answer 2

只需使用 If olItem.Attachments.Count > 0 Then strColE = "YES"

实施例

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

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

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

然后将 xlSheet.Range("E" & rCount) = strColE ' Attament 添加到

    '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

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

2 个答案: