Question

我正在尝试编写一个代码，用于对我的Outlook中的一个收件箱进行排序，以查找具有特定主题的电子邮件，并将电子邮件的正文（其表格）复制到Excel中。这就是我到目前为止所拥有的。无法让代码工作，但不知道如何指定我想要搜索的收件箱。感谢任何帮助！

Sub CopyEmail()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItms As Outlook.Items
    Dim olMail As Variant

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace(”MAPI”) 'get a runtime error here
    Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
    Set olItms = olFldr.Items

    Dim NLXemail As String
    NLXemail = "Patient Receipts"

    olItms.Sort NLXemail

         If InStr(1, olMail.Subject, NLXemail, vbTextCompare) > 0 Then
            ThisWorkbook.Sheets("Sheet1").Cells(3, 1).Value = outMail.Body

        End If

    Set olFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

End Sub

Answer 1

这会将正文复制到Excel以及更多内容。

Option Explicit
'This Code is Downloaded from OfficeTricks.com
'Visit this site for more such Free Code
Sub Export_Outlook_Emails_To_Excel()
    'Add Tools->References->"Microsoft Outlook nn.n Object Library"
    'nn.n varies as per our Outlook Installation
    Dim Folder As Outlook.MAPIFolder
    Dim sFolders As Outlook.MAPIFolder
    Dim iRow As Integer, oRow As Integer
    Dim MailBoxName As String, Pst_Folder_Name  As String

    'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
    MailBoxName = "MailBox Name"

    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
    Pst_Folder_Name = "Folder Name" 'Sample "Inbox" or "Sent Items"

    'To directly a Folder at a high level
    'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

    'To access a main folder or a subfolder (level-1)
    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
        If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
        For Each sFolders In Folder.Folders
            If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                Set Folder = sFolders
                GoTo Label_Folder_Found
            End If
        Next sFolders
    Next Folder

Label_Folder_Found:
     If Folder.Name = "" Then
        MsgBox "Invalid Data in Input"
        GoTo End_Lbl1:
    End If

    'Read Through each Mail and export the details to Excel for Email Archival
    ThisWorkbook.Sheets(1).Activate
    Folder.Items.Sort "Received"

    'Insert Column Headers
    ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
    ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
    ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
    ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
    ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
    'ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"

    'Export eMail Data from PST Folder
    oRow = 1
    For iRow = 1 To Folder.Items.Count
        'If condition to import mails received in last 60 days
        'To import all emails, comment or remove this IF condition
        If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
           oRow = oRow + 1
           ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
           ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
           ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
           ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
           ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
           ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
           'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
        End If
    Next iRow
    MsgBox "Outlook Mails Extracted to Excel"
    Set Folder = Nothing
    Set sFolders = Nothing

End_Lbl1:
End Sub

有关详细信息，请参阅以下链接。

http://officetricks.com/outlook-email-download-to-excel/

Answer 2

想出来。下面的脚本在特定的Outlook邮箱中查找特定的电子邮件，并将电子邮件正文中的内容（表格）复制到excel中。

Sub Copyemailbody_refresh()

Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim MailBoxName As String, Pst_Folder_Name  As String
Dim oMail As Outlook.MailItem
Dim y As Long, x As Long
Dim olInsp As Outlook.Inspector
Dim wdDoc As Word.Document
Dim tb As Word.Table
Dim Myemail As String
Dim Atmt As Attachment
Dim irow As Integer
irow = 1
'set email date
Dim Emaildate As String
Emaildate = Sheets("Refresh").Range("G12").Value
'set email subject
Myemail = "Today's receipts " & Emaildate”
'Mailbox or PST Main Folder Name to set the name of the inbox - I have several mailboxes, needed to specify
 MailBoxName = "Mymailbox1"  

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
 Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"

'To direct to a Folder at a high level
 Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'copying the email contents into the refresh file
For Each oMail In Folder.Items
 If oMail.Subject = Myemail Then
  With oMail
  Set olInsp = .GetInspector
  Set wdDoc = olInsp.WordEditor

  For Each tb In wdDoc.Tables 'assumes only 1 table in the body of the email

For y = 1 To tb.Rows.Count
For x = 1 To tb.Columns.Count

 Sheets("Refresh").Select 
 Range("A1").Select 
 Selection.Offset(y, x).Value = tb.Cell(y, x).Range

    Next

  Next

 Next

    End With

End If

Next

 'since the table was pasted as a word object, needed to convert text to numbers to perform calc on the table– not sure of a quicker way to do this than Text to columns

Sheets("Refresh").Select
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited
Columns("E:E").Select
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited
End Sub

用于搜索电子邮件并将正文复制到Excel中的VBA代码

2 个答案: