none
VBA Email extract problem RRS feed

  • Question

  • Hi, 

    I'm quite new to VBA. I'm using a code to extract certain information from e-mail and write this to excel. Everything is working fine except for one field. The field, "comment:" has variable information, including empty lines. This code only extract the information until the empty line but therefore I'm missing the rest of the information. Is there a way to modify the code to include the full input in the comment section? Many thanks in advance!

    The code I'm using:

    Sub CopyToExcel()
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim olItem As Outlook.MailItem
    Dim vText As Variant
    Dim sText As String
    Dim vItem As Variant
    Dim i As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim objItem As Object
    Dim SenderEmailAddress As String
    Dim SenderName As String
    Dim Subject As String
    
    Const strPath As String = "V:\DestinationFile.xls"
    
    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")
    
    'Process each selected record
    rCount = xlSheet.UsedRange.Rows.Count
    For Each olItem In Application.ActiveExplorer.Selection
    
    SenderName = olItem.SenderName
    xlSheet.Range("B" & rCount + 1) = SenderName
    
    SenderEmailAddress = olItem.SenderEmailAddress
    xlSheet.Range("A" & rCount + 1) = SenderEmailAddress
    
    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), "country:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("C" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "why:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "interest:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("D" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "comment:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("E" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "telephone:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("F" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "practice:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("G" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "role:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("H" & rCount) = Trim(vItem(1))
    End If
    
    If InStr(1, vText(i), "provider:") > 0 Then
    vItem = Split(vText(i), Chr(58))
    xlSheet.Range("I" & rCount) = Trim(vItem(1))
    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


    Friday, October 16, 2015 9:56 AM

Answers

  • The simplest thing to do would be to require that every line contained in the comment section begin with your "comment:" field name, even if the remainder of the line does not contain any text.  That is because the way the code is written it will discard any line in the vText array that does not contain one of your predefined field names.

    You can set a flag after the first line that is a "comment:" and check that flag when reading subsequent lines so that a line with no field name can be treated as a "comment:".  When the code encounters a line with a different field name then it can unset the flag.

    Friday, October 16, 2015 11:02 AM