将数据从Outlook 2010导入Excel 2010

Question

我在我的网站上有一张表格，当客户完成该表格后会通过电子邮件发送该表格，如下所示：-

You got mail from  Mr Kelley McIntyre.

Here is the form data:
First Name   : Mr XXXXX
Last Name    : XXXXXX
Company Name     : Army
Email Address    : XXXX@hotmail.co.uk
Telephone/Mobile No      : 0123456789
Date of Event    : 14/12/2013
Number of Guests     : 80
Budget   : 6500-7000
Type of Event    : Other
Catering Required    : Yes
Drinks and Entertainment Requirements    : christmas meal, welcome drink, wine at table

British Army Warrant Officers & Sergeants plus wives and partners
How Did You Hear About Us?   : Google

如您所见，它的格式相当简单，但是，每当收到其中一封电子邮件时，我都需要将此数据导出到Excel中，这样我就可以记录我们收到的所有查询。

有人可以帮忙吗？ 我知道如何做一个宏，但是如果它是VBA，那我就迷路了，所以如果可能的话，它必须是白痴格式！

Answer 1

您可以从编写宏来处理邮件项目开始。 并设置Outlook Rule以从“主题/帐户”中提取此类电子邮件，然后运行宏。 根据需要更改sExcelFile，sRecordSheet，iC。 我做了假设。

下面的代码适用于Outlook，请注意，您需要一直运行Outlook才能实现此自动化。 它应该使您入门一半。 请注意，您的引用中需要“ Microsoft Excel x.0对象库”。

Public Sub Rules_WebSiteFormRecord(oMail As MailItem)

    Const sExcelFile As String = "C:\Test\Record.xlsx"
    Const sRecordSheet As String = "Record" ' Worksheet name

    Dim oExcel As Excel.Application, oWB As Excel.Workbook, oWS As Excel.worksheet
    Dim arrTxt As Variant, oLine As Variant, iR As Long, iC As Long, bWrite As Boolean

    Set oExcel = CreateObject("excel.application")
    Set oWB = oExcel.Workbooks.Open(FileName:=sExcelFile)
    Set oWS = oWB.Worksheets(sRecordSheet)
    ' Make Excel visible for Debug purpose:
    oExcel.Visible = True
    ' Find next row of Last used row in Excel worksheet
    iR = oWS.Cells(Rows.Count, 1).End(xlUp).Row + 1
    ' Process email body and store it into columns of worksheet "sRecordSheet"
    'Debug.Print oMail.Body
    ' Store received time of email in Column A
    oWS.Cells(iR, 1).Value = oMail.ReceivedTime
    ' Split the email body into lines then process each
    arrTxt = Split(oMail.Body, vbCrLf)
    For Each oLine In arrTxt
        bWrite = False
        ' store data according to text in line
        If InStr(1, oLine, "First Name", vbTextCompare) Then
            iC = 2 ' Column of First Name
            bWrite = True
        ElseIf InStr(1, oLine, "Last Name", vbTextCompare) Then
            iC = 3 ' Column of First Name
            bWrite = True
            ' Add the rest of the fields...
        End If
        If bWrite Then
            oWS.Cells(iR, iC).Value = Split(oLine, ":")(1)
            iR = iR + 1
        End If
    Next
    Set oWS = Nothing
    ' Close the workbook with saving changes
    oWB.Close True
    Set oWB = Nothing
    Set oExcel = Nothing
    ' mark it as Read if no error occurred
    If Err.Number = 0 Then
        oMail.UnRead = False
    Else
        MsgBox "ERR(" & Err.Number & ":" & Err.Description & ") while processing " & oMail.Subject
        Err.Clear
    End If
End Sub