如何批量复制outlook邮件正文到excel中并且保留格式

chocolate39

邮件如图和附件。其实只需要邮件正文的表格，但如果麻烦，把其他文字复制到excel影响也不大。我现在写了下面一个VBA代码，思路是把需要处理的邮件放到指定文件夹“a”中，然后每封邮件复制到一个工作表中。但这样邮件正文只能复制到一个单元格内，不能保留格式，我想要的效果如图所示，还按照表格的形式复制到excel，方便筛选整理。我把EmailBody定义成字符串变量，肯定是没办法保留格式，但我实在是不知道怎么样才能保留。有办法通过代码复制邮件正文吗？我试过用TheMail.body.Copy，这样不对。


Sub table()
    Set outlookapp = CreateObject("outlook.application")
    Set myitem = outlookapp.Application.GetNamespace("mapi")
    Set Myfolder = myitem.GetDefaultFolder(olFolderInbox).Folders("a")
    mailcounts = Myfolder.Items.Count
    If (MsgBox(mailcounts & " pieces of letter in a!", vbYesNo) = vbNo) Then Exit Sub
   
    If mailcounts > 0 Then
        Dim EmailBody As String
        
        For i = 1 To mailcounts
            Set TheMail = Myfolder.Items(i)
            EmailBody = TheMail.body
            Sheets(i).Cells(1, 1) = EmailBody
            
        Next i
        
    End If
           
End Sub

chocolate39

我看过dsd999 版主的“Outlook VBA开发第五讲-导出邮件到Excel，每个发件人一个Sheet ”这个帖子，看代码应该也是把邮件正文复制到一个单元格内了，无法保留格式，查了半天也没看到可以批量复制并保留格式的VBA代码。利用outlook自带的导出到excel的功能，也是把正文放在了一个单元格内了。

chocolate39

自己找到解决办法了。将HTMLBody写入剪贴板就行了。唉，折腾了半天。

Sub EmailToExcel()

    Set outlookapp = CreateObject("outlook.application")
    Set myitem = outlookapp.Application.GetNamespace("mapi")
    Set Myfolder = myitem.GetDefaultFolder(olFolderInbox).Folders("a")
   
    mailcounts = Myfolder.Items.Count
   
   
    Dim MyDataObj As New DataObject
    MyDataObj.SetText ""

    If (MsgBox(mailcounts & " pieces of letter in a!", vbYesNo) = vbNo) Then Exit Sub
   
    If mailcounts > 0 Then
        
        For i = 1 To mailcounts
        
            If Worksheets.Count < mailcounts Then
                Sheets.Add After:=Sheets(Sheets.Count)
            End If
        
            Set TheMail = Myfolder.Items(i)
            
            MyDataObj.SetText (TheMail.HTMLBody)
            MyDataObj.PutInClipboard
            
            Sheets(i).Select
            Sheets(i).Range("A1").Select
            ActiveSheet.Paste
            
            MyDataObj.SetText ""
               
            
        Next i
        
    End If
           
End Sub

elon23

chocolate39 发表于 2012-10-25 17:18
自己找到解决办法了。将HTMLBody写入剪贴板就行了。唉，折腾了半天。

Sub EmailToExcel()

运行了说类型定义错误呢？