Question

我们有一份实习申请表（通过formsite.com），预期实习生填写并提交。所有提交都以表格的形式在MS Excel中接收。但是，有一些学位/专业，我们在表格中有其他问题，因此收到的电子邮件的结构保持不变，但表格中的行数可能不同（根据申请人的问题数量）必须回答）。

由于有数千个这样的应用程序，我一直在尝试将代码导出到Excel中。我在Excel中尝试了以下代码，但需要弄清楚如何针对不同行数调整它 - 如果我输入最大行数，则不会导入行数较少的电子邮件：

Sub ParseEmailFolderToExcel()
    Set objApp = Application
    Dim olns As Outlook.Namespace
    Set olns = Outlook.GetNamespace("MAPI")
    Set myinbox = olns.PickFolder
    Dim XLApp As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim EachElement()
    Dim myRecipient As Outlook.Recipient

    Dim ExcelWasNotRunning As Boolean

    On Error Resume Next
    Set XLApp = GetObject(, "Excel.Application")

    If Err Then
       ExcelWasNotRunning = True
       Set XLApp = New Excel.Application
       XLApp.Visible = True
    End If
    On Error GoTo 0
    Set wkb = XLApp.Workbooks.Add
    Set wks = wkb.Sheets(1)
    With wks
        StartCount = 1 'how many emails (start at 1 to leave row one for headers)
        strEmailContents = ""
        For Each outlookmessage In myinbox.Items
            StartCount = StartCount + 1 'increment email count

            Set myRecipient = olns.CreateRecipient(Right(outlookmessage.SenderEmailAddress, 5))
            myRecipient.Resolve
            If myRecipient.Resolved Then
                Debug.Print myRecipient.AddressEntry.GetExchangeUser().PrimarySmtpAddress
            End If

            UseCol = 1 'E; previous columns hold the email header information shown above (sender, date, etc)

            FullMsg = outlookmessage.Body
            AllLines = Split(FullMsg, vbCrLf)

            For FullLine = LBound(AllLines) To UBound(AllLines)
                On Error Resume Next
              'Here is where you could decide to process only certain lines, using maybe a select case statement

                eachVal = Split(AllLines(FullLine), ":") 'for a comma delimited file
                For EachDataPoint = LBound(eachVal) To UBound(eachVal) 'load each value to an array
                    UseCol = UseCol + 1
                    ReDim Preserve EachElement(UseCol)
                    '.cells(row,column)
                    EachElement(UseCol - 1) = eachVal(EachDataPoint)
                    '.Cells(StartCount, UseCol - 1).Value = eachVal(EachDataPoint)
                Next
            Next
            On Error GoTo 0

            'Now place just the selected data into the output workbook- from the array. Not necessary if you process lines individually and paste their data directly into Excel as you go

            wks.Cells(StartCount, 1) = EachElement(1)
            wks.Cells(StartCount, 2) = EachElement(2)
            wks.Cells(StartCount, 3) = EachElement(3)
            wks.Cells(StartCount, 4) = EachElement(4)
            wks.Cells(StartCount, 5) = EachElement(5)
            wks.Cells(StartCount, 6) = EachElement(6)
            wks.Cells(StartCount, 7) = EachElement(7)
            wks.Cells(StartCount, 8) = EachElement(8)
            wks.Cells(StartCount, 9) = EachElement(9)
            wks.Cells(StartCount, 10) = EachElement(10)
            wks.Cells(StartCount, 11) = EachElement(11)
            wks.Cells(StartCount, 12) = EachElement(12)
            wks.Cells(StartCount, 13) = EachElement(13)
            wks.Cells(StartCount, 14) = EachElement(14)
            wks.Cells(StartCount, 15) = EachElement(15)
            wks.Cells(StartCount, 16) = EachElement(16)
            wks.Cells(StartCount, 17) = EachElement(17)
            wks.Cells(StartCount, 18) = EachElement(18)
            wks.Cells(StartCount, 19) = EachElement(19)
            wks.Cells(StartCount, 20) = EachElement(20)
            wks.Cells(StartCount, 21) = EachElement(21)
            wks.Cells(StartCount, 22) = EachElement(22)
            wks.Cells(StartCount, 23) = EachElement(23)
            wks.Cells(StartCount, 24) = EachElement(24)
            wks.Cells(StartCount, 25) = EachElement(25)
            wks.Cells(StartCount, 26) = EachElement(26)
            wks.Cells(StartCount, 27) = EachElement(27)
            wks.Cells(StartCount, 28) = EachElement(28)
            wks.Cells(StartCount, 29) = EachElement(29)
            wks.Cells(StartCount, 30) = EachElement(30)
            wks.Cells(StartCount, 31) = EachElement(31)
            wks.Cells(StartCount, 32) = EachElement(32)
            wks.Cells(StartCount, 33) = EachElement(33)
            wks.Cells(StartCount, 34) = EachElement(34)
            wks.Cells(StartCount, 35) = EachElement(35)
            wks.Cells(StartCount, 36) = EachElement(36)
            wks.Cells(StartCount, 37) = EachElement(37)
            wks.Cells(StartCount, 38) = EachElement(38)
            wks.Cells(StartCount, 39) = EachElement(39)
            wks.Cells(StartCount, 40) = EachElement(40)
            wks.Cells(StartCount, 41) = EachElement(41)

        Next
    End With

    UseRow = 1
    wks.Range("E1") = EachElement

    Set myOlApp = Nothing
    Set olns = Nothing
    Set myinbox = Nothing
    Set myItems = Nothing
End Sub

非常感谢您的帮助！

Answer 1

我不能100％确定这是否解决了您的问题，但是尝试更换所有

wks.Cells(StartCount, ..) = EachElement(..)

使用：

Dim i As Integer
  For i = 1 To UBound(EachElement)
  wks.Cells(StartCount, i) = EachElement(i)
Next

这可以解决您的问题

每当电子邮件结构略有不同时，将Outlook电子邮件的特定内容导出到Excel

1 个答案: