'this routine pulls emails from Outlook to Excel and loads them into tblEmail.
'adapted for Access by Denis Wright.
'original code from VBAX, http://www.vbaexpress.com/forum/showthread.php?t=29711
'Calls: ProcessFolder
Sub Launch_Pad()
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim Date1, Date2
Dim dtmLast As Date
Dim rst As DAO.Recordset
Set rst = CurrentDb.QueryDefs("qryLastMail").OpenRecordset
If rst.BOF And rst.EOF Then 'no records
Date1 = DateSerial(2000, 1, 1)
Else
dtmLast = rst!RecTime \ 1
Date1 = DateAdd("d", 1, dtmLast)
End If
Date2 = DateAdd("d", 1, Date)
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
Call ProcessFolder(olFolder, Date1, Date2)
rst.Close
Set rst = Nothing
Set olNS = Nothing
Set olFolder = Nothing
Set olApp = Nothing
Set olNS = Nothing
End Sub
Sub ProcessFolder(olfdStart As Outlook.MAPIFolder, Date1, Date2)
Dim olFolder As Outlook.MAPIFolder
Dim olObject As Object
Dim olMail As Outlook.MailItem
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim i As Long
Set dbs = DBEngine(0)(0)
Set rst = dbs.TableDefs("tblEmail").OpenRecordset
i = 1
For Each olObject In olfdStart.Items
If TypeName(olObject) = "MailItem" Then
If olObject.ReceivedTime >= Date1 And olObject.ReceivedTime < Date2 Then
Call SysCmd(acSysCmdSetStatus, "Importing Email message " & i)
Set olMail = olObject
With rst
.AddNew
!Subject = olMail.Subject
If Not olMail.UnRead Then !ReadStatus = "Message is read" Else !ReadStatus = "Message is unread"
!RecTime = olMail.ReceivedTime
!LastMod = olMail.LastModificationTime
!Cat = olMail.Categories
!SenderName = olMail.SenderName
!RequestFlag = olMail.FlagRequest
!BodyText = olMail.Body
!CreateBy = Environ("username")
.Update
End With
i = i + 1
End If
End If
Next
Set olMail = Nothing
Set olFolder = Nothing
Set olObject = Nothing
rst.Close
Set rst = Nothing
dbs.Close
Set dbs = Nothing
Call SysCmd(acSysCmdClearStatus)
End Sub
