如何将多封电子邮件中的数据导出到Excel工作簿但不同的工作表？

Question

我想将所选 Outlook 电子邮件中的数据导出到工作簿。每封电子邮件的数据（主题、正文等）应存储在不同的工作表中。

我正在尝试编辑这个宏，因为它几乎是我所需要的——尤其是

olFormatHTML

和

WordEditor

的部分——因为分裂。

这个想法是

1. 在 Outlook 中选择多封电子邮件
2. 打开文件路径
3. 所选每封电子邮件的数据将存储在打开的文件的单个工作表中

宏的问题在第三部分

1. 从所选项目中，宏执行循环并仅获取所选的第一封电子邮件，
2. 数据存储在不同的工作簿中；它应该存储在我打开的同一工作簿中。

Public Sub SplitEmail() 
    
    Dim rpl As Outlook.MailItem
    Dim itm As Object
    Dim sPath As String, sFile As String
    Dim objDoc As Word.Document
    Dim txt As String
    Dim xlApp As Excel.Application
    Dim wb As Excel.Workbook
    Dim i As Long
    Dim x As Long
    '----------------------------
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
        
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection
       
    For x = 1 To myOlSel.Count
        
        '----------------------------------------------
        Set itm = GetCurrentItem() 'A)I think the issuefrom selecting 1 item is located here
    
        '|||||||||||||||||||||||||||||||||||||||||

        sPath = "C:\Users\Ray\"
        sFile = sPath & "Macro.xlsm"

        If Not itm Is Nothing Then
            Set rpl = itm.Reply
            rpl.BodyFormat = olFormatHTML
            'rpl.Display
        End If
            
        Set objDoc = rpl.GetInspector.WordEditor
        txt = objDoc.Content.Text
    
        '||||||||||||||||||||||||||||||||||||||||||||||
        
        Set xlApp = CreateObject("Excel.application")
        xlApp.Visible = True
        Set wb = xlApp.Workbooks.Open(sFile) 'B) tried to move it to the beginning and macro doesn't work
        
        '||||||||||||||||||||||||||||||||||||||||||||||

        For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
            wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i) 'B)emails in different sheet but no same workbook
        Next i    
            
    '------------------------------------------------------
    Next x
       
End Sub


Function GetCurrentItem() As Object
    
    Dim objApp As Outlook.Application
    Set objApp = Application
    On Error Resume Next
    
    Select Case TypeName(objApp.ActiveWindow)
    Case "Explorer"
    Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
        Case "Inspector"
        Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
    GetCurrentItem.UnRead = False
    Set objApp = Nothing
    
End Function

Answer 1

我更新了这个宏
由于宏 do 在

For x

中循环，它打开文件 x 次，
然后关闭它并再次打开，而不是处理第一个打开的工作簿
但宏留下了开放的实例
这是当前代码

Public Sub SplitEmail()


    Dim rpl As Outlook.MailItem
    Dim itm As Object
    Dim sPath As String, sFile As String
    Dim objDoc As Word.Document
    Dim txt As String
    Dim xlApp As Excel.Application
    Dim wb As Excel.Workbook
    Dim i As Long
    Dim x As Long
    '----------------------------
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    
    Set myOlExp = Application.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
For x = 1 To myOlSel.Count
    
    '----------------------------------------------
    
    Dim objApp As Outlook.Application
    Dim GetCurrentItem As Object
        Set objApp = Application
        On Error Resume Next
    
        Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
        Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(x)
        Case "Inspector"
        Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
        End Select
        
        GetCurrentItem.UnRead = False
        Set objApp = Nothing
    
    '-----------------------------------------------
    Set itm = GetCurrentItem


    sPath = "C:\Users\Ray\"
    sFile = sPath & "Macro.xlsm"
   
    
    If Not itm Is Nothing Then
    
        'de lo contrario, se crea un Reply del correo en formato HTML
        Set rpl = itm.Reply
        rpl.BodyFormat = olFormatHTML
        'rpl.Display
    End If
        
    
    Set objDoc = rpl.GetInspector.WordEditor
    txt = objDoc.Content.Text

    '||||||||||||||||||||||||||||||||||||||||||||||
    
    Set xlApp = CreateObject("Excel.application")
    xlApp.Visible = True
    
    Set wb = xlApp.Workbooks.Open(sFile)
    xlApp.Windows("Macro.xlsm").Activate
    'Set wb = ActiveWorkbook
    '||||||||||||||||||||||||||||||||||||||||||||||

    

    
        For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
            wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i)
        Next i
        
    xlApp.Windows("Macro.xlsm").Close SaveChanges:=True
        xlApp.Workbook.Close SaveChanges:=False
'------------------------------------------------------



Next x
'------------------------------------------------------


'the instances should closed but not working, instances are empty

        For Each wb In xlApp
           wb.Close SaveChanges:=False
        Next


End Sub

Answer 2

完成，我在保存文件后添加了

xlApp.Quit

并删除了最后一部分

For Each wb In xlApp...