如何将写发件人的电子邮件地址Excel集成到现有代码中

Question

我正在使用电子邮件模板将接收到的选定电子邮件中的内容解析到Excel中，以便可以将其加载到其他软件中-我希望VBA将发件人的电子邮件地址写入“ E”列（下一个可用列）中每个选定的电子邮件

我已经在寻找解决方案，但是在将它们集成到当前的VBA时遇到困难

         Sub CopyToExcel()

          Dim xlApp As Object
          Dim xlWB As Object
          Dim xlSheet As Object
          Dim olItem As Outlook.MailItem
          Dim vText As Variant
          Dim sText As String
          Dim vItem As Variant
          Dim i As Long
          Dim rCount As Long
          Dim bXStarted As Boolean
          Dim obj As Outlook.MailItem


          Const strPath As String = "C:\Users\HDew\Desktop\Responses.xlsx"                                        'the path of the workbook
         If Application.ActiveExplorer.Selection.Count = 0 Then
              MsgBox "No Items selected!", vbCritical, "Error"
              Exit Sub
          End If
          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

          'Open the workbook to input the data
          Set xlWB = xlApp.Workbooks.Open(strPath)
          Set xlSheet = xlWB.Sheets("Sheet1")

          'Process each selected record
          For Each olItem In Application.ActiveExplorer.Selection
              sText = olItem.Body
              vText = Split(sText, Chr(13))
              'Find the next empty line of the worksheet
             rCount = xlSheet.UsedRange.Rows.Count
              rCount = rCount + 1

                 For i = UBound(vText) To 0 Step -1



            If InStr(1, vText(i), "Matter:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If

              If InStr(1, vText(i), "Activity:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "Quantity:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If

            If InStr(1, vText(i), "Note:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Trim(vItem(1))
            End If


                 Next i

              xlWB.Save
          Next olItem
          If bXStarted Then
              xlApp.Quit
          End If
          Set xlApp = Nothing
          Set xlWB = Nothing
          Set xlSheet = Nothing
          Set olItem = Nothing
          End Sub

还应该将发件人的电子邮件地址写到“ E”列中-目前完全不写

谢谢您的时间！