Parse email messages, feed data to .mdb

[SyntaxSocialist]

Hi all. Hopefully I'm not duplicating a topic here, but I haven't been able to find what I've been looking for elsewhere so here goes:

I've built an HTML web form that sends an email to me upon submission with all the field inputs. I have previously found success using VBA in Outlook to parse out these emails and feed the substrings into an Excel Sheet (hooray!), but now am looking to feed the substrings into Access, specifically into a table in an existing .mdb file. I figure the way Outlook will "talk to" Access will likely be a bit different from the way it does for Excel, so I'd greatly appreciate any pointers, resources, starting points, or the like that could get me on my way.

The way my previous script engaged with Excel was through a rule; every time a new email was received, the following script would run if the message had the subject line generated by my web form. The script would check whether Excel and the target workbook/sheet was open, act accordingly, and then input the substrings (I've excluded that part below), then return Excel and the wb/ws to their initial state. I imagine though, that with Access I might be able to feed the substrings into the .mdb without having to open it proper, the way a front-end talks to a back-end. But perhaps I'm mistaken on that front.

Option Explicit
Option Compare Text

Public Const xlUp As Integer = -4162 'I genuinely do not know what this is _
                                                  about. It came with the initial _
                                                  borrowed code.
Public Const wbPath As String = "C:\...Workbook.xlsx" 'Workbook path
Public Const wbName As String = "Woorkbook.xlsx" 'Workbook file name
Public Const wbSheet1 As String = "Sheet1" 'Title of 1st sheet in WB

Public Sub ExportToExcel(MyMail As MailItem)
    
    Dim olMail As Outlook.MailItem
    Dim olNS As Outlook.NameSpace

    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    
    Dim i As Byte 'Counter
    Dim lRow As Byte 'Rows in WS

    Dim excelOpen As Boolean, wbOpen As Boolean
            excelOpen = False
            wbOpen = False
    
    Dim strID As String, respCut As String
    
    strID = MyMail.EntryID
    
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
    
    'Retrieve/establish an Excel application object
    On Error GoTo NoExcel: 'See bottom of Sub
    Set oXLApp = GetObject(, "Excel.Application")
    
    excelOpen = True
        
    If IsWorkBookOpen(wbPath) = True Then
        wbOpen = True
    End If
    
RunUpdates:
    'Open the relevant file if not already opened
    If wbOpen = False Then
        Set oXLwb = oXLApp.Workbooks.Open(wbPath)
    Else
        Set oXLwb = oXLApp.Workbooks(wbName)
    End If
    
    Set oXLws = oXLwb.Sheets(wbSheet1)
    
    'Find first empty row to enter data
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1
        
          'Substrings then fed into Excel (code excluded)

    'Define what to do when done; depends on initial state of application and _
    workbook
    Select Case excelOpen + wbOpen
        Case -2 'TT
            oXLwb.Save
            
        Case -1 'TF
            oXLwb.Close (True)
            
        Case 0 'FF
            oXLwb.Close (True)
            oXLApp.Quit
    End Select

    Set oXLws = Nothing
    Set oXLApp = Nothing
    Set oXLwb = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    
    Exit Sub
    
NoExcel:
    'If Excel is not open then create new instance
    Set oXLApp = CreateObject("Excel.Application")
    Err.Clear
    On Error GoTo 0
    Resume RunUpdates
    
End Sub
'-----------------------------------------------------------------
Private Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error GoTo ErrCapture:
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    
ErrCapture:
    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

 

[Uncle Gizmo]

If this comment in the code is yours, then I think you answer is in the link below:-
>>>I genuinely do not know what this is about. It came with the initial borrowed code<<<

http://visualbasic.about.com/od/quicktips/qt/copyExcelRow.htm

Extract:-
xlUp is actually another "magic number" or more technically, an enumerated constant. If you check it out in Object Browser, you'll see that it's actually the number -4162. But that doesn't mean anything except that the End method recognizes it. (You can actually substitute -4162 for xlUp and it works the same way.) And Offset(1, 0) simply moves up one row in the same column, so the net effect is to select the last cell in column C.

 

[SyntaxSocialist]

xlUp is actually another "magic number" or more technically, an enumerated constant. If you check it out in Object Browser, you'll see that it's actually the number -4162. But that doesn't mean anything except that the End method recognizes it. (You can actually substitute -4162 for xlUp and it works the same way.) And Offset(1, 0) simply moves up one row in the same column, so the net effect is to select the last cell in column C.

Neat! Thanks! Any insight on the Outlook-to-Access problem?

 

[Uncle Gizmo]

I can't see in your code where you pass the outlook values to Excel?

Is something missing?

 

[SyntaxSocialist]

I can't see in your code where you pass the outlook values to Excel?

Yes I left them out (there's a comment to that effect), as I expect there to be a degree of similarity between the methods in that regard. If you need the full code, here it is:

'Transfer data from emails (form responses) to an Excel sheet.

Option Explicit
Option Compare Text

'Constants, to be modified as needed
Public Const xlUp As Integer = -4162 'I genuinely do not know what this is about. It came with the initial borrowed code.
Public Const wbPath As String = "C:\...Workbook.xlsx" 'Workbook path
Public Const wbName As String = "Workbook.xlsx" 'Workbook file name
Public Const wbSheet1 As String = "Sheet1" 'Title of 1st sheet in WB

Public Sub ExportToExcel(MyMail As MailItem)
    
    Dim olMail As Outlook.MailItem
    Dim olNS As Outlook.NameSpace

    Dim oXLApp As Object
    Dim oXLwb As Object
    Dim oXLws As Object
    
    Dim i As Byte 'Counter
    Dim lRow As Byte 'Rows in WS

    Dim excelOpen As Boolean
            excelOpen = False
            
    Dim wbOpen As Boolean
            wbOpen = False
        
    Dim myAr() As String
    
    Dim strID As String
    Dim respCut As String
    
    'Variables for parsing out email messages
    Dim emailAddress As String
    Dim projTitle As String
    Dim sigImpact As String
    Dim rsrchExcellence As String
    Dim rsrchTeam As String
    Dim hqpInvest As String
    Dim prtnrsCapBldg As String
    Dim projSustainability As String
    Dim addtnlComments As String
    Dim fnlRating As String
    Dim lvlConfidence As String
    
    strID = MyMail.EntryID
    
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
    
    myAr() = Split(olMail.Body, "<<<") 'A string array of the parsed email message
    
    'Retrieve/establish an Excel application object
    On Error GoTo NoExcel: 'See bottom of Sub
    Set oXLApp = GetObject(, "Excel.Application")
    
    excelOpen = True
        
    If IsWorkBookOpen(wbPath) = True Then
        wbOpen = True
    End If
    
RunUpdates:
    'Open the relevant file if not already opened
    If wbOpen = False Then
        Set oXLwb = oXLApp.Workbooks.Open(wbPath)
    Else
        Set oXLwb = oXLApp.Workbooks(wbName)
    End If
    
    Set oXLws = oXLwb.Sheets(wbSheet1)
    
    lRow = oXLws.Range("A" & oXLApp.Rows.Count).End(xlUp).Row + 1 'Finds the first empty row to enter data
    
    For i = LBound(myAr) To UBound(myAr)
        respCut = Mid(myAr(i), InStr(myAr(i), ">>>") + 4, Len(myAr(i)) - (InStr(myAr(i), ">>>") + 7)) 'Represents each data point (response from form)
        
        'Define where to put each data point (form response) in the spreadsheet
        Select Case i
            Case 1
            emailAddress = respCut
            oXLws.Range("A" & lRow).Value = emailAddress
            Case 2
            projTitle = respCut
            oXLws.Range("B" & lRow).Value = projTitle
            Case 3
            sigImpact = respCut
            oXLws.Range("C" & lRow).Value = sigImpact
            Case 4
            rsrchExcellence = respCut
            oXLws.Range("D" & lRow).Value = rsrchExcellence
            Case 5
            rsrchTeam = respCut
            oXLws.Range("E" & lRow).Value = rsrchTeam
            Case 6
            hqpInvest = respCut
            oXLws.Range("F" & lRow).Value = hqpInvest
            Case 7
            prtnrsCapBldg = respCut
            oXLws.Range("G" & lRow).Value = prtnrsCapBldg
            Case 8
            projSustainability = respCut
            oXLws.Range("H" & lRow).Value = projSustainability
            Case 9
            addtnlComments = respCut
            oXLws.Range("I" & lRow).Value = addtnlComments
            Case 10
            fnlRating = respCut
            oXLws.Range("J" & lRow).Value = fnlRating
            Case 11
            lvlConfidence = respCut
            oXLws.Range("K" & lRow).Value = lvlConfidence
            Case Else 'ignore
        End Select
    Next i
        
    'Define what to do when done; depends on initial state of application and workbook
    Select Case excelOpen + wbOpen
        Case -2 'TT
            oXLwb.Save
            
        Case -1 'TF
            oXLwb.Close (True)
            
        Case 0 'FF
            oXLwb.Close (True)
            oXLApp.Quit
    End Select

    Set oXLws = Nothing
    Set oXLApp = Nothing
    Set oXLwb = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
    
    Exit Sub
    
NoExcel:
    'If Excel is not open then create new instance
    Set oXLApp = CreateObject("Excel.Application")
    Err.Clear
    On Error GoTo 0
    Resume RunUpdates
    
End Sub

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

    On Error GoTo ErrCapture:
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    
ErrCapture:
    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

 

[jdraw]

Does this apply to your situation?

 

[Uncle Gizmo]

And what does the table look like where you want to transfer the values to?

To show the table here easily, open the query designer, select the Table, drag the relevant fields into the query designer grid.

Open the SQL View of the query - Copy and paste that SQL here..

 

[Uncle Gizmo]

I think item 7 on this page:- http://www.helenfeddema.com/Code%20Samples.htm

Might have some code for moving data from Outlook to Access.

Extract:-
This code sample includes an Outlook form and an Access database. For Office 97, the code writes most of the standard Outlook fields from the current contact item to a new row in a table in the Access database. For Office 2000 or higher, an Outlook macro (VBA procedure) runs from a toolbar button, to export both standard and custom data from any contact item or mail message.

Not sure if it's hosted by outlook or access.

 

[Uncle Gizmo]

Another approach:-
http://msdn.microsoft.com/en-us/library/bb256372(v=office.12).aspx

Extract:-
To work with Microsoft Access objects through Automation, you must create an instance of the Microsoft Access Application object. For example, suppose you want to display data from Microsoft Excel in a Microsoft Access form or report. To launch Microsoft Access from Microsoft Excel, you can use the New keyword to create an instance of the Microsoft Access Application object. You can also use the CreateObject method to create a new instance of the Microsoft Access Application object, or you can use the GetObject method to point an object variable to an existing instance of Microsoft Access. Check your component's documentation to determine which syntax it supports.

 

[spikepl]

Many ways to skin a cat:

I do all the parsing in Access, becasue it is so much easier to make changes and updates in Access rayher than update people's Outlook:. So in Access I have this:

Public Function ParseStuff(MySubject As String, MyDate As Date, MyStuff As String) As Long 
    
    'here I parse MySTuff and get the info I want

    ParseStuff= SomeFlag' retuning a value to Outlook to say how it went

End Function

In outlook I have this "macro" (that is what Outlook calls it) that I can activate from a custom button when the email to be parsed is open

Sub ParseStuff()

    Dim MyItem As MailItem

    Dim result As Long

    Dim objDbase As Object
    Dim appAccess As Object

    On Error GoTo ParseStuff_Error

    Set MyItem = Application.ActiveInspector.CurrentItem
    
    Set appAccess = GetObject(PAthOfmyAccessDb)
    

    result = appAccess.Run("ParseStuff", MyItem.Subject, MyItem.SentOn, MyItem.HTMLBody) '[COLOR=Red]note that if you send MyItem.Body and not MyItem.HTMLbody, then all HTML will be stripped out - can be convenient[/COLOR]

    If result = 0 Then
        MsgBox "Data was saved", vbInformation
    End If

    If result < 0 Then
        MsgBox "Data was not saved due to error in DB", vbExclamation
    End If

    If result > 0 Then
        MsgBox "This data already exists in DB", vbExclamation
    End If

    Set MyItem = Nothing

    Set appAccess = Nothing

ParseStuff_Exit:

    On Error Resume Next

    Exit Sub

ParseStuff_Error:

    Select Case Err.Number

         Case Else

             MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ParseStuff of VBA Document ThisOutlookSession"
         
             Resume ParseStuff_Exit

    End Select

 

[SyntaxSocialist]

Sorry it's taken me so long to get back to you all on this! I've been plugging away at it while managing a few other projects. I also hit a few roadblocks that took some time to overcome. Done now, though!

Does this apply to your situation?

Thanks jdraw. The page you linked to led me here, which almost did the trick for me. Unfortunately, various restrictions at my workplace prevented me from using this solution. Perhaps it's for the best, as I would have had less control over formatting and presentation using that option. Still, though, good to know!

I think item 7 on this page:- http://www.helenfeddema.com/Code%20Samples.htm
Might have some code for moving data from Outlook to Access.

Indeed it did! Thank you! After much tinkering and learning, this got me through to my end goal! See my completed code below.

'Transfer data from emails (form responses) to Access.

'The following references are required:
    'Microsoft Scripting Runtime
    'Microsoft Access 11.0 Object Library
    'Microsoft DAO 3.6 Object Library

Option Explicit
Option Compare Text

'Constants, to be modified as needed
    Const tblName As String = "Archive_Main_Table" 'Access table name
    Const dbPath As String = "C:\...Programs.mdb" 'DB path

Sub ExportToAccess(MyMail As MailItem)
    
    Dim olMail As Outlook.MailItem
    Dim olNS As Outlook.NameSpace

    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset

    Dim appAccess As Object
        
    Dim i As Byte 'Counter

    Dim myAr() As String
    
    Dim strID As String
    Dim propID As String
    Dim respCut As String
    
    'Variables for parsing out email messages
    Dim grant As String
    Dim projTitle As String
    Dim awardID As String
    'etc.
    
    strID = MyMail.EntryID
    
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
    
    myAr() = Split(olMail.Body, "<<<") 'A string array of the parsed email message
    
    Set appAccess = CreateObject("Access.Application")
    Set dbs = CreateObject("DAO.DBEngine.36").Workspaces(0).OpenDatabase(dbPath)
    Set rst = dbs.OpenRecordset(tblName, dbOpenDynaset)
    
    'Get Proposal ID from message subject, determine if record with that ID already exists
    propID = Right(Trim(olMail.Subject), 5)
    
    rst.FindFirst "[Proposal ID] = '" & propID & "'"
    
    'If record already exists, edit. Else add new.
    If rst.NoMatch = False Then 'If recExist > 0 Then
        rst.Edit
    Else
        rst.AddNew
        rst![Proposal ID] = propID
    End If
    
    For i = LBound(myAr) To UBound(myAr)
        respCut = Mid(myAr(i), InStr(myAr(i), ">>>") + 4) 'Represents each data point (response from form)
        
        'Omitted a few lines here where I just trimmed and tidied respCut to prepare it for input into the DB.

        'Define where to put each data point (form response) in the spreadsheet
        Select Case i
            Case 1
                grant = respCut
                rst![...] = grant
            Case 2
                projTitle = respCut
                rst![...] = projTitle
            Case 3
                awardID = respCut
                rst![...] = awardID
                
            'Case 4 is propID; already set
            
            Case 5
                lastName = respCut
                rst![...] = lastName
       
            'etc.

            Case Else
                'ignore
        End Select
    Next i
    
    rst.Update
    rst.Close
    dbs.Close
    appAccess.Quit
    Set appAccess = Nothing
    Set olMail = Nothing
    Set olNS = Nothing
End Sub