CODEWITHSUNDEEP
sqlvbams-accessoutlook
Jazzmasterflex
Jazzmasterflex

Reputation: 31

Finding Outlook Email Address of mailitem via SQL/VBA with Access

Using Access/VBA/SQL to get various email properties from the inbox as I transfer it into a new table "MyInbox".

Sub InboxImport()
    Dim SqlString As String
    Dim ConnectionString As String
    Dim EmailTableName As String
    Dim UserIdNum As String
    Dim EmailAddr As String
    Dim olNS As Outlook.NameSpace
    Dim olFol As Outlook.Folder

    Set ol = CreateObject("Outlook.Application")
    Set olNS = ol.GetNamespace("MAPI")
    Set olFol = olNS.GetDefaultFolder(olFolderInbox)

    EmailTableName = "MyInbox"
    UserIdNum = Environ("USERNAME")  '1277523A...
    EmailAddr = olFol.Parent.Name 'Gives your user email address
    ConnectionString = "Outlook 9.0;MAPILEVEL=" & EmailAddr & "|;PROFILE=Default Outlook Profile;TABLETYPE=0;TABLENAME=MyInbox;COLSETVERSION=12.0;DATABASE=C:\Users\" & UserIdNum & "\AppData\Local\Temp\"

    SqlString = "SELECT [From] As [Sender], [Email] As [Email Addy], [Subject Prefix] & [Normalized Subject] As Subject, [Contents] As [Body], [Received] As [ReceivedTime]" & _
            " INTO [MyInbox]" & _
             " From [" & ConnectionString & "].[Inbox]"

    DoCmd.SetWarnings False
    DoCmd.RunSQL SqlString
    DoCmd.SetWarnings True
End Sub

I'm trying to find the "Sender Email" address for every email item in the inbox. As run, it currently pops up with a "Enter Parameter..." with a blank value for [Email].

Is there a good compiled reference for looking up all these different kinds of email SQL terms?

Upvotes: 1

Views: 927

Answers (1)

June7
June7

Reputation: 21370

Loop through email items. Unfortunately, the INSERT sql has issue with embedded special characters in the email body, apparently related to hyperlinks. I didn't think it worthwhile figuring out how to get around it.

Public Sub ImportEmails()

' Set up Outlook objects.
Dim ol As New Outlook.Application
Dim of As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim mo As Outlook.MailItem, Atmt As Outlook.Attachment
'Set of = ol.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Folders("Repairs")
Set of = ol.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set objItems = of.Items

Dim rst As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("MyInbox")

For Each mo In objItems

    'CurrentDb.Execute "INSERT INTO MyInbox SELECT '" & mo.SenderEmailAddress & "' AS Sender, '" & _
        mo.SenderName & "' AS SenderName, '" & mo.Subject & "' AS Subject, '" & _
        mo.body & "' AS Body, #" & mo.ReceivedTime & "# AS Received"

    rst.AddNew
    rst!EmailAdd = mo.SenderEmailAddress
    rst!SenderName = mo.Sender
    rst!Subject = mo.Subject
    rst!body = mo.body
    rst!Received = mo.ReceivedTime
    rst.Update
    'For Each Atmt In mo.Attachments
    '    Atmt.SaveAsFile "C:\path\" & Atmt.FileName
    'Next

Next
End Sub

Upvotes: 1

Related Questions