Public iItem As Integer
'Public Function FileExists(ByVal Filename As String) As Boolean
'
'Dim nAttr As Long
'
'On Error GoTo NoFile
'
'nAttr = GetAttr(Filename)
'
'If (nAttr And vbDirectory) <> vbDirectory Then
'
'FileExists = True
'
'End If
'
'NoFile:
'
'End Function
 
Sub ExtractData()
Dim oItem As MailItem
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
For Each oItem In ActiveExplorer.Selection
If oItem.Subject = "New email received" Then
    CopyToExcel oItem
End If
Next oItem
Set oItem = Nothing
End Sub
Sub CopyToExcel(olItem As MailItem)
'Dim olItem As Outlook.MailItem
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long
Dim bXStarted As Boolean
Dim FinalRow As Long
Dim strParameter As String
Dim strParamValue As String
Dim DateTime As String
Dim YourEmail As String
Const strWorkSheetName As String = "Data"
Const strWorkBookPath As String = "C:\"
Const strWorkBookName As String = "Data.xls"
'the path of the workbook
'Use FileExists function to determine the availability of the workbook
If Dir(strWorkBookPath & strWorkBookName) = "" Then Exit Sub
'Set olItem = Application.ActiveExplorer.Selection(iItem)
'Get Excel if it is running, or open it if not
On Error Resume Next
Set xlApp = GetObject("Excel.Application")
'Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
 
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks(strWorkBookName)
If TypeName(xlWB) = "Nothing" Then
    Set xlWB = xlApp.Workbooks.Open(strWorkBookPath & strWorkBookName)
End If
Set xlSheet = xlWB.Sheets("Data")
'Process the message
With olItem
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
FinalRow = xlSheet.Cells(xlSheet.Rows.Count, "B").End(xlUp).Row + 1
For i = UBound(vText) To 0 Step -1
 
    vItem = Split(vText(i), Chr(9))
 
    strParameter = ""
    strParamValue = ""
 
    strParameter = Trim(Replace(vItem(0), Chr(10), ""))
    strParamValue = Trim(vItem(1))
 
    Select Case strParameter
        Case "Time Submitted:"
            xlSheet.Range("B" & FinalRow) = strParamValue
            DateTime = strParamValue
        Case "Your name"
            xlSheet.Range("C" & FinalRow) = strParamValue
        Case "Your email"
            xlSheet.Range("D" & FinalRow) = strParamValue
            YourEmail = strParamValue
        Case "Team"
            xlSheet.Range("E" & FinalRow) = strParamValue
        Case "Your telephone number"
            xlSheet.Range("F" & FinalRow) = "'" & strParamValue
        Case "Field1?"
            xlSheet.Range("G" & FinalRow) = strParamValue
        Case "Field2?"
            xlSheet.Range("H" & FinalRow) = strParamValue
        Case "Field3?"
            xlSheet.Range("I" & FinalRow) = strParamValue
        Case "ThField4?"
            xlSheet.Range("J" & FinalRow) = strParamValue
        Case "Field5?"
            xlSheet.Range("K" & FinalRow) = strParamValue
        Case "Field6?"
            xlSheet.Range("L" & FinalRow) = strParamValue
    End Select
 
Next i
If xlApp.WorksheetFunction.CountIf(xlSheet.Range("A2:A10000"), DateTime & YourEmail) > 1 Then
    xlSheet.Range("B" & FinalRow & ":L" & FinalRow).ClearContents
Else
    xlWB.Save
End If
End With
 
xlWB.Close SaveChanges:=True
''
'If bXStarted Then
'
xlApp.Quit
'
'End If
 
Set xlApp = Nothing
 
Set xlWB = Nothing
 
Set xlSheet = Nothing
 
End Sub