從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

回答

相關問題