Save data in excel file through Outlook

Question

I created a Rule, that every time an email arrives with a certain text on Subject executes a scrip, which has the function of going through the entire email and storing certain data in an Excel sheet.

Code:

 Option Explicit

 Sub CopyToExcelMacro()
 Dim olItem As Outlook.MailItem
 Dim xlApp As Excel.Application
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim vText, vText2, vText3, vText4, vText5, vText6, vText7, vText8, vText9 As Variant
 Dim sText As String
 Dim texto As String
 Dim rCount As Long
 Dim rValue As Integer
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String


enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "\Documents\Fieldanalysis.xlsx"

 Dim Ret
     Do
    Ret = IsWorkBookOpen(strPath)

    If Ret = True Then
        MsgBox "File is open Deve fechar os ficheiro excel"
    Else
        MsgBox "File is Closed"
    End If
    Loop While Ret = True

     On Error Resume Next
     Set xlApp = New 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("Fieldanalysis")
    ' Process the message record
    Set olItem = Application.ActiveExplorer().Selection(1)
    'Find the next empty line of the worksheet
     rCount = xlSheet.Range("D" & xlSheet.Rows.Count).End(-4162).Row
     'rValue = xlSheet.Range("A" & rCount - 1).Value
     'rValue = rValue + 1
     rCount = rCount + 1


    sText = olItem.Body

    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match

    Dim strSubject As String
    Dim testSubject As String

    Dim i As Integer


    Set Reg1 = New RegExp

    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric


For i = 1 To 9

With Reg1
    Select Case i
    Case 1
        .Pattern = "(Complain. Cust.:+\s*\n*(\w*)\s*)"
        .Global = False

    Case 2
        .Pattern = "(Part number:+\s*\n*(\w*)\s*)"
        .Global = False


    Case 3
        .Pattern = "(QC-Number:+\s*\n*(\w*\d*)\s*)"
        .Global = False

    Case 4
        .Pattern = "(Manufact. date:+\s*\n*(\w*/\w*/\w*)\s*)"
        .Global = False

    Case 5
        .Pattern = "(Analysis Result+\s*\n*([\w*\s*]*)\s*)"
        .Global = False

    Case 6
        .Pattern = "(Cause text:+\s*\n*(\w*\s*\w*)\s*)"
        .Global = False

    Case 7
        .Pattern = "(Supplier name:+\s*\n*(\w*)\s*)"
        .Global = False

    Case 8
        .Pattern = "(Part number:+\s*\n*([\d]{4}\.[\d]{3}\.[\d]{3})\s*)"
        .Global = False

    Case 9
        .Pattern = "(Mileage \(Km\):+\s*\n*(\w*)\s*)"
        .Global = False

    End Select
    End With


    If Reg1.test(sText) Then

        Set M1 = Reg1.Execute(sText)
        For Each M In M1
            Debug.Print M.SubMatches(1)
            strSubject = M.SubMatches(1)

        Select Case i
            Case 1
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText = strSubject

            Case 2
                'vText2 = Trim(M.SubMatches(1))
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText2 = strSubject

            Case 3
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText3 = strSubject
                'vText3 = Trim(M.SubMatches(1))

            Case 4
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText4 = strSubject
                'vText4 = Trim(M.SubMatches(1))

            Case 5
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText5 = strSubject
                'vText5 = Trim(M.SubMatches(1))
            Case 6
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText6 = strSubject

            Case 7
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText7 = strSubject

            Case 8
                'vText2 = Trim(M.SubMatches(1))
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText8 = strSubject

            Case 9
                strSubject = M.SubMatches(1)
                strSubject = Replace(strSubject, Chr(13), "")
                'vText = Trim(M.SubMatches(1))
                vText9 = strSubject
                'vText3 = Trim(M.SubMatches(1))

        End Select
        Next M
     End If

         'strSubject = Replace(strSubject, Chr(13), "")
         'testSubject = testSubject & "; " & Trim(strSubject)
         'Debug.Print i & testSubject

         'Next




Next i



  'xlSheet.Range("A" & rCount) = rValue
  xlSheet.Range("D" & rCount) = vText
  xlSheet.Range("E" & rCount) = vText2
  xlSheet.Range("F" & rCount) = vText3
  xlSheet.Range("G" & rCount) = vText4
  xlSheet.Range("H" & rCount) = vText5
  xlSheet.Range("I" & rCount) = vText6
  xlSheet.Range("J" & rCount) = vText7
  xlSheet.Range("K" & rCount) = vText8
  xlSheet.Range("L" & rCount) = vText9

    Call MsgBox("Foi guardado no ficheiro excel: " & vbLf & "Complain. Cust: " & vText & vbLf & " Part number: " & vText2 & vbLf & " QC-Number: " & vText3 & vbLf & " Manufact. date: " & vText4 & vbLf & " Analysis Result: " & vText5 & vbLf & " Cause text: " & vText6 & vbLf & " Supplier name: " & vText7 & vbLf & " Part number: " & vText8 & vbLf & " Mileage (Km): " & vText9)
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If

     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
 End Sub

 Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

Problem:

Sometimes the scrip works but can’t get the data, But if I re-check the email for myself it already works.

Can anyone identify any problems? I think it should be in the statement of some variable or at the end of the program when I have to close the variables(this is my opinion) Why:

• Rule is always executed when the email arrives(but sometimes it does not catch the data I want)

  ->So it shouldn’t be a problem for the email to arrive with a Subject different

• It can’t be problems from REGEX because if the email I received did not worked if re-send to me works

Like I never programmed VBA I’m not sure if start/close the variables correctly, so think that the problem comes from there.