Outlook 在 Excel 工作簿中导出多封电子邮件但不同的 Excel 工作表

如何解决Outlook 在 Excel 工作簿中导出多封电子邮件但不同的 Excel 工作表

我是使用 vba 的新手，我想从选择的 Outlook 电子邮件导出到工作簿路径，并且每封电子邮件（主题、正文等）都应存储在不同的工作表中，我正在尝试编辑此宏，因为它几乎是我需要的，特别是 olFormatHTML 和 WordEditor 的部分，因为 split

这个想法是
1.-在Outlook中选择多封电子邮件
2.-打开文件路径
3.-对于在 Outlook 中选择的每封电子邮件将存储在打开的文件中的单个工作表中

我在第三部分遇到宏问题
A).- 从选定的项目中，宏会循环并选择第一封电子邮件
B).- 电子邮件存储在不同的工作簿中，应该存储在我打开的同一个工作簿中

这是代码

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,1)
            wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt,Chr(13))(i) 'B)emails in diferrent 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

这个问题是B：上面的代码，当宏do循环“x”增加时，不同工作表但不同工作簿中的电子邮件存储应该在同一个工作簿中

解决方法

我更新了这个宏
作为 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,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

,

完成，我在保存文件后添加了 xlApp.Quit 并删除了最后一部分 For Each wb In xlApp...