从Outlook邮件整理表格到Excel表格使用Excel VBA

我有一个Excel文件，它将用作一个工具从邮件中整理表格。一封邮件只有一个表格和一条记录。我需要将所有这些表中的记录（来自不同的邮件）整理到一个Excel表格中。我有下面的代码来做到这一点。这段代码在运行时，将邮件正文中的整个文本复制到Excel中（因此，只有当邮件具有表格而邮件正文中没有其他文本时，该代码才起作用）。但是我只需要将邮件中的表格复制到Excel中。请帮我修改代码来做到这一点。请注意，我不想在Outlook中编写任何代码。复制的表格也以文本形式粘贴。我希望他们能够以表格格式粘贴。下面显示了需要修改的部分代码。从Outlook邮件整理表格到Excel表格使用Excel VBA

Public Sub ExportToExcel1() 

Application.ScreenUpdating = False

'变量声明

Dim i As Integer 
Dim ns As Namespace 
Dim Inbox As Outlook.MAPIFolder 
Dim item As Object 
Dim doClip As MSForms.DataObject 
Dim d As String

' 变量

i = 2 
d = ActiveSheet.Range("subject").Value 

Set ns = GetNamespace("MAPI") 
Set Inbox = ns.GetDefaultFolder(olFolderInbox) 
Set doClip = New MSForms.DataObject

“循环检查邮件和提取数据

For Each item In Inbox.Items 
    If TypeName(item) = "MailItem" And item.Subject = d Then 
     doClip.SetText item.Body 
     doClip.PutInClipboard 
     ActiveSheet.Cells(1, 1).PasteSpecial "Text" 

EndSub

来源

2014-04-07 Syed Kaleel Awn

中有两处错误设定值的代码：

您访问item.Body当您需要Html正文时，它是文本正文。
当您只需要表格时，将整个主体粘贴到工作表中。

你需要一些额外的变量：

If TypeName(item) = "MailItem" And item.Subject = d Then 

     Html = item.HTMLBody 
     LcHtml = LCase(Html) 
     PosStart = InStr(1, LcHtml, "<table") 
     If PosStart > 0 Then 
     PosEnd = InStr(PosStart, LcHtml, "</table>") 
     If PosEnd > 0 Then 
      Debug.Print "[" & Mid(Html, PosStart, PosEnd + 8 - PosStart) & "]" 
      doClip.SetText Mid(Html, PosStart, PosEnd + 8 - PosStart) 
      doClip.PutInClipboard 
      ActiveSheet.Cells(1, 1).PasteSpecial "Text" 
     End If 
     End If 

    End If

来源

2014-04-14 17:58:35

非常感谢@Tony：

Dim Html As String Dim LcHtml As String Dim PosEnd As Long Dim PosStart As Long

与更换If声明。这有助于... –

@ user2691260不客气。我希望你接受答案。 –

从Outlook邮件整理表格到Excel表格使用Excel VBA

回答

相关问题