Here’s some code I found *out there*, adapted somewhat to suit my needs:
Private Sub get_Emails(strEmailContents As String)
Dim strEmailBody As String
‘declare a variable to hold the email body text
‘if your field is not called contents, change this bit below
strEmailBody = strEmailContents
‘stremail now holds the email body
‘these are variables to show the email where the body “headers” are
rankpos = 0
lastnamepos = 0
usernamepos = 0
‘these are variables to show where in the email body the actual values are
rank = “”
lastname = “”
UserName = “”
‘this is a variable to show where we are in the email body….
currentpos = 1
‘look for the words “Rank:” – this must be EXACLTY how it appears in the email
rankpos = InStr(currentpos, strEmailBody, “Rank:”)
currentpos = rankpos
lastnamepos = InStr(currentpos, strEmailBody, “Last Name:”)
currentpos = lastnamepos
usernamepos = InStr(currentpos, strEmailBody, “Username:”)
currentpos = usernamepos
‘we now know where all the headers are, so find the text inbetween them and assign them to the appropriate variables:
‘ie the first name wiil be between First Name and Last Name
If rankpos 0 And lastnamepos 0 Then
fieldlen = Len(“Rank:”)
firstname = Mid(strEmailBody, rankpos + fieldlen, lastnamepos – (rankpos + fieldlen))
End If
If lastnamepos 0 And usernamepos 0 Then
fieldlen = Len(“Last Name:”)
lastname = Mid(strEmailBody, lastnamepos + fieldlen, usernamepos – (lastnamepos + fieldlen))
End If
Dim srtSQLInsert As String
strSQLInsert = “insert into [company_user] ([rank],[last_name],[username]) values(‘” & Trim(rank) & “‘,'” & Trim(lastname) & “‘,'” & Trim(UserName) & “‘)”
DoCmd.SetWarnings (False)
DoCmd.RunSQL (strSQLInsert)
End Sub
However, I still don’t know how to get the email into access….The following code is provided, but I’m having trouble understanding it.
Private Sub Form_Open(Cancel As Integer)
Dim dbs As Database
Dim rst As DAO.Recordset
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(“Outlook New Registration Emails”)
With rst
If .RecordCount 0 Then
Do While Not rst.EOF
‘procedure from button
get_Emails (rst.Fields(“Contents”))
rst.MoveNext
Loop
End If
End With
‘deletes all the records in the linked outlook table
deleteoutlookregistrationtable = “Delete from [Outlook New Registration Emails]”
‘this command runs the deletion of the outlook registrations new table
DoCmd.SetWarnings (False)
DoCmd.RunSQL (deleteoutlookregistrationtable)
DoCmd.SetWarnings (False)
‘DoCmd.Close
DoCmd.Quit ACSaveAll
End Sub
