ub SaveEmailErrors(OutlookFolderInInbox As String, aantal As Integer)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim i As Integer
Dim wsh As Object
Dim fs As Object
Dim TempRst As DAO.Recordset
Dim rst As DAO.Recordset
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from tbl_outlooktemp"
DoCmd.SetWarnings True
Set db = CurrentDb
Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp")
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
For Each Item In SubFolder.Items
i = i + 1
With TempRst
If Left(Item.Class, 2) = 43 Then
.AddNew
!Subject = Item.Subject
!From = Item.SenderName
!To = Item.To
!Body = Item.Body
!Datesent = Item.SentOn
!EntryID = Item.EntryID
!i = i
!Class = Item.Class
!Parent = Item.Parent
!ReceivedByName = Item.ReceivedByName
!SendUsingAccount = Item.SendUsingAccount
!SenderName = Item.SenderName
!SenderEmailAddress = Item.SenderEmailAddress
!Sender = Item.Sender
.Update
Else
.AddNew
!Subject = Item.Subject
!Body = Item.Body
!EntryID = Item.EntryID
!i = i
!ConversationID = Item.ConversationID
!Class = Item.Class
!Parent = Item.Parent
.Update
End If
End With
Next Item
aantal = i
' Clear memory
ThisMacro_exit:
TempRst.Close
Set TempRst = Nothing
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "folder does not exist"
Resume ThisMacro_exit
End Sub
