Saving E-mail attachments - Choose mailbox

[cyb3rwolf]

Hello everyone,

I have a form which saves e-mail attachments from unread messages in a specific folders in outlook. This works great, without any problems. However, now I need to figure out how to get it to save attachments from a mailbox other than the default one. My code is pasted below; kind of a mess cause i've been trying different things.

Dim TempRst As DAO.Recordset
Dim rst As DAO.Recordset
Dim olApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim objNameSpace As Outlook.NameSpace
Dim InboxItems As Outlook.Items
Dim Mailobject As Object
Dim db As DAO.Database
Dim dealer As Integer
Dim oMessage As Outlook.MailItem
Dim atmt As Outlook.Attachment
Dim filename As String
Dim i As Integer
i = 0
Set db = CurrentDb
Dim ictr As Integer
ictr = 0
Dim DTAddress As String
DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Dim filesender As String
Dim filenm As String
Dim sppath As String
Dim colFolders As Folders
Dim objReadFolder As MAPIFolder
Dim ShortText As String
Dim temp As String
Dim cmMailBoxName As String
cmMailBoxName = "(omitted mailbox name)"
MsgBox cmMailBoxName
Set olApp = CreateObject("Outlook.Application")
Set objNameSpace = olApp.GetNamespace("MAPI")
Set colFolders = objNameSpace.Folders
Set objReadFolder = colFolders.Item(cmMailBoxName)
Set Inbox = objReadFolder.Folders.Item("(ommitted folder name)").Items

Set InboxItems = Inbox.Items
''
'Set OlApp = CreateObject("Outlook.Application")
'Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox).Folders("InquireTest")
'Set TempRst = CurrentDb.OpenRecordset("tbl_OutlookTemp")
'Set InboxItems = Inbox.Items

For Each Mailobject In InboxItems
If Mailobject.UnRead Then
ictr = ictr + 1
For Each atmt In Mailobject.Attachments
'MsgBox atmt
i = i + 1
'FileName = "X:\" & Mailobject.SenderName + CStr(i) & Right(atmt.FileName, 4)
filename = "X:\" & atmt
sppath = "(omitted)" & atmt
MsgBox sppath
atmt.SaveAsFile filename
DoEvents
InsertIntoX2 (sppath)
filenm = filenm + Mailobject.SenderName + CStr(i) + " " 'This is used to put the file names into the email reader table

filesender = filesender + Mailobject.SenderName + CStr(i) + " " ' This is used for the message box at the end that shows all the files
'temp = OpenTextFileToString2(FileName)

'Me.CustName = GetBetween(temp, "Name:", "New:")
'Me.Address = GetBetween(temp, "Address:", "Building:")
'Me.City = GetBetween(temp, "City:", "State:")
'Me.State = GetBetween(temp, "State:", "Zip:")
'Me.Zip = GetBetween(temp, "Zip:", "Date Wanted:")


Next atmt

With TempRst

.AddNew
!subject = Mailobject.subject
MsgBox (!subject)

!FromName = Mailobject.SenderName
!To = Mailobject.To
!Body = Mailobject.Body
!DateSent = Mailobject.SentOn
!File = filenm
.Update
Mailobject.UnRead = False
filenm = "" ' empty the string before it goes to the next email
End With
End If

Next

Set olApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set Mailobject = Nothing
Set TempRst = Nothing
Me.Requery
If i > 0 Then MsgBox i & " Files were saved."
If ictr = 0 Then MsgBox "There were no new emails to handle"
Me.tenantchanges.Requery
End Sub

 

[cyb3rwolf]

Bump. I should also add that what I have doesn't actually give an error, it just doesnt work. I made a test outlook folder with 10 unread emails with attachments. When I just run it on the default inbox, it saves all 10 attachments, and displays the message box indicating 10 emails were saved (that code is commented out in the code I pasted), and all emails at marked unread as it goes. When I try to run the code with trying to specify the exact mailbox, the message box says one attachment was saved, yet none are and all mail remain marked unread.

 

[cyb3rwolf]

Bump again.