将部分 MS Outlook 电子邮件导出到 Excel 文件

Question

我有以下 2 个我希望从 MS Outlook 导出的电子邮件类型示例。我包括了一个全天和一个半天。

**FULL DAY**

Employee Name:  PEEWEE LOZANO
Employee ID:    356352
Contact Phone Number:   4161234567
Location:   ALBERTA
Absence report submitted:   08-25-2017 09:56
Type of Absence:    FULL DAY
Time zone:  Eastern Time
Nature of absence:  NON-SICKNESS
Absence reason:     REGULAR

**PARTIAL DAY**
Employee Name:  THAMARA HEYWOOD
Employee ID:    326899
Contact Phone Number:   6477654321
Location:   TORONTO
Absence report submitted:   08-25-2017 09:16
Type of Absence:    PARTIAL DAY
Absence start date/time:    08-25-2017 09:00
Absence end date/time:  08-25-2017 10:30
Time zone:  Eastern Time
Total absence duration:     01:30 hours
Nature of absence:  NON-SICKNESS
Absence reason:     REGULAR

我们正在寻找的 excel 的输出是

 +-----------------+---------+----------+----------+------------+------------+-----------+----------+--------------+----------+---------+----------------+
|    Emp.Name     | Emp. ID | Location |   Type   | Start Date | Start Time | End Date  | End Time |     Zone     | Duration | Reason  |      Memo      |
+-----------------+---------+----------+----------+------------+------------+-----------+----------+--------------+----------+---------+----------------+
| PEEWEE LOZANO   |  356352 | TORONTO  | FULL DAY | 8/25/2017  |            |           |          | Eastern Time |          | REGULAR | 8/25/2017 9:56 |
| THAMARA HEYWOOD |  326899 | TORONTO  |          | 8/25/2017  | 9:00       | 8/25/2017 | 10:30    | Eastern Time | 1:30     | REGULAR | 8/25/2017 9:16 |
+-----------------+---------+----------+----------+------------+------------+-----------+----------+--------------+----------+---------+----------------+

此外，每次导出时，我们首先需要删除 excel 文件中 header 下面的所有行，然后再添加新记录。

我需要 select 并一次导出几条记录。

我是 Outlook 的新手 VB，不知道从哪里开始。任何帮助将不胜感激。

Answer 1

访问后http://www.gmayor.com/extract_data_from_email.htm

我提出了以下效果很好的解决方案

Sub CopyToExcel_Original()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim strItem As String
Dim bXStarted As Boolean
Const olMailItem As Long = 0
Const strPath As String = "\xxxx\xxs\xxxxT\test.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
xlSheet.Range("A1:Z500").Clear
xlSheet.Range("A1").Select

With xlSheet
.Cells(1, 1) = "Emp.Name"
.Cells(1, 2) = "Emp. ID"
.Cells(1, 3) = "Location"
.Cells(1, 4) = "Type"
.Cells(1, 5) = "Start Date"
.Cells(1, 6) = "Start Time"
.Cells(1, 7) = "End Date"
.Cells(1, 8) = "End Time"
.Cells(1, 9) = "Zone"
.Cells(1, 10) = "Duration"
.Cells(1, 11) = "Reason"
.Cells(1, 12) = "Memo"
End With

'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
 rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
  If InStr(1, vText(i), "Employee Name:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("A" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Employee ID:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("B" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Location:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("C" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Type of Absence:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Absence start date/time:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    strItem = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
    vItem = Split(strItem, Chr(32))        'split at the space
    xlSheet.Range("E" & rCount) = Trim(vItem(0)) 'the date
    xlSheet.Range("F" & rCount) = Trim(vItem(1)) 'the time
    End If

    If InStr(1, vText(i), "Absence end date/time:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    strItem = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))
    vItem = Split(strItem, Chr(32))        'split at the space
    xlSheet.Range("G" & rCount) = Trim(vItem(0)) 'the date
    xlSheet.Range("H" & rCount) = Trim(vItem(1)) 'the time
    End If

    If InStr(1, vText(i), "Time zone:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("I" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Total absence duration:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("J" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))

    End If

    If InStr(1, vText(i), "Absence reason:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("K" & rCount) = Trim(vItem(1))
    End If

    If InStr(1, vText(i), "Absence report submitted:") > 0 Then
        vItem = Split(vText(i), Chr(58))
        xlSheet.Range("L" & rCount) = Trim(vItem(1)) & Chr(58) & Trim(vItem(2))

    End If


Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

将部分 MS Outlook 电子邮件导出到 Excel 文件

Exporting parts of MS Outlook emails to and Excel file

outlook-2013