Outlook 在 Excel 工作簿中導出多封電子郵件，但不同的 excel 工作表

Question

我是使用 vba 的新手，我想從選擇到工作簿路徑的 outlook 電子郵件中導出，每個 email（主題、正文和嘗試編輯的工作表等）應該存儲在此宏中，因為它幾乎不同我需要，尤其是olFormatHTML和WordEditor的一部分，因為拆分

這個想法是
1.-在 Outlook 中選擇多封電子郵件
2.-打開文件路徑
3.-對於在 Outlook 中選擇的每個 email 將從打開的文件中存儲在單個工作表中

我在第 3 部分中遇到了宏的問題
A).- 從選定的項目中執行宏循環並選擇第一個 email
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, Chr(13)), 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 loop“x”增加時，email存儲在不同的工作表中但在不同的工作簿中，應該在同一個工作簿中

Answer 1

我對此宏進行了更新
作為宏在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...