reading email text from body and pass to access database (1 Viewer)

[megatronixs]

Hi all,

I made in the past a macro that would scan emails in outlook and if they had a particular subject, then the body would be scanned and the text passed to excel workbook.
Now I try to alter the code to make it pass it to the access database.
I did many things, but this one is a harder one.
Any clue how I can change the bellow to make it work?

Public iItem As Integer
 
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 = "Training: Mega VBA" 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
 
'//-------------------------------------------------------------------------
Dim strTable    As String
Dim con         As Object
Set con = CreateObject("ADODB.connection")
Set con = CreateObject("ADODB.connection")
strTable = "tbl_enrolment"
AccessFile = "C:\Training team\training_tools_db.accdb"
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
'Dim db   As DAO.Database
Dim tbl_enrolment As Recordset
'Set enrolment_table = CurrentDb.OpenRecordset("tbl_enrolment")
'Set db = CurrentDb()
 
'On Error Resume Next
'If Err <> 0 Then
  
'Process the message
 
With olItem
 
sText = olItem.Body
vText = Split(sText, Chr(13))
 
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))
        
        
    'enrolment_table.AddNew
        
    Select Case strParameter
        Case "Event ID:"
            tbl_enrolment("event_id") = strParamValue
        Case "Trainer name:"
            tbl_enrolment("Trainer name") = strParamValue
        Case "Training Topic:"
            tbl_enrolment("Training Topic") = strParamValue
            'YourEmail = strParamValue
        Case "Training Type:"
            tbl_enrolment("Training Type") = strParamValue
        Case "Training Location:"
            tbl_enrolment("Training Location") = "'" & strParamValue
        Case "Start Date:"
            tbl_enrolment("Start Date") = strParamValue
'        Case "Training Duration:"
'            enrolment_table("Training Duration") = strParamValue
'        Case "Who is the idea for?"
'            xlSheet.Range("I" & FinalRow) = strParamValue
'        Case "The problem"
'            xlSheet.Range("J" & FinalRow) = strParamValue
'        Case "The_solution"
'            xlSheet.Range("K" & FinalRow) = strParamValue
'        Case "Potential number of customers impacted by change each week?"
'            xlSheet.Range("L" & FinalRow) = strParamValue
    End Select
    
Next i
 
End With
 
 
     db.Close
    Set db = Nothing
 
 
End Sub

Greetings.

 

[megatronixs]

Hi all,

I managed to solve it, it was not easy.....
Just for the ones that would like to use the soluion:

Private Sub btn_process_enrolment_emails_Click()
'//--------- Dim and Set------------------------
Dim TempRst         As DAO.Recordset
Dim rst             As DAO.Recordset
Dim db              As DAO.Database
Dim vText           As Variant
Dim sText           As String
Dim i               As Long, j As Long
Dim rCount          As Long
Dim strParameter    As String
Dim strParamValue   As String
Dim oItem           As MailItem
Dim olApp           As Outlook.Application
Dim objNS           As Outlook.NameSpace
Dim olFolder        As Outlook.MAPIFolder
Set db = CurrentDb
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Training Team Enrolment")
Set TempRst = CurrentDb.OpenRecordset("tbl_enrolment")
 
For Each InboxItem In olFolder.Items
If InboxItem.Subject Like "RE: Training:*" Then
    If InboxItem.UnRead Then
    With TempRst
        .AddNew
sText = InboxItem.Body
vText = Split(sText, Chr(13))

For i = UBound(vText) To 0 Step -1
    
    vItem = Split(vText(i), Chr(9))
    
    strParameter = ""
    strParamValue = ""
 On Error Resume Next
    strParameter = Trim(Replace(vItem(0), Chr(10), ""))
    strParamValue = Trim(vItem(1))

    Select Case strParameter
        Case "Event ID:"
            !event_id = strParamValue
        Case "Trainer name:"
            !trainer_name = strParamValue
        Case "Training Topic:"
            !training_topic = strParamValue
        Case "Training Type:"
            !training_type = strParamValue
        Case "Training Location:"
            !training_location = strParamValue
        Case "Start Date:"
            !start_date = strParamValue
        Case "Training Duration:"
            !training_duration = strParamValue
    End Select
    
Next i
 .Update
 InboxItem.UnRead = False
 InboxItem.FlagStatus = olFlagComplete
End With
End If
 
Set TempRst = Nothing
End If
Next
End Sub