Dr.K
06-03-2011, 12:26 PM
We have an Outlook Exchange server at work, with some shared mailboxes. I have a bunch of VBA programs that I run from Excel to help manage these mailboxes. The following chunk of code is part of a sub that copies Attachments with certain names to a local temp folder, and then uploads the data to an Access DB.
'**Set up Outlook objects
Set OutApp = CreateObject("Outlook.Application")
Set OutNS = OutApp.GetNameSpace("MAPI")
Set OutRecipient = OutNS.CreateRecipient(ABC_MailboxName)
Set OutFolder = OutNS.GetSharedDefaultFolder(OutRecipient, 6) 'olFolderInbox = 6
Set OutFolderManual = OutFolder.Folders("ABC Manual")
Set OutFolderErr = OutFolder.Folders("ABC Upload Errors")
'**Pull in Files from ABC:Inbox (Only correctly named files)
'Get Mailitems from Inbox
Set OutItems = OutFolder.Items
'restrict and sort items
Set OutItems = OutItems.Restrict("[MessageClass] = 'IPM.Note'")
OutItems.Sort "[Received]", False
'iterate through mailitems in inbox to find Mail Items with correctly named attachment
'copy to temp directory (in order)
lngCount = 0
'get first item
Set OutMail = OutItems.GetFirst
'begin loop
Do While TypeName(OutMail) <> "Nothing"
'branch on Attachments: if no attachments, skip to end
If OutMail.Attachments.Count > 0 Then
Set OutAttachments = OutMail.Attachments
For Each OutAttach In OutAttachments
If OutAttach.Filename = constABCInputFName Then
'increase count
lngCount = lngCount + 1
'Store Entry ID and Recieved date/time
ReDim Preserve arrEmails(1 To 3, 1 To lngCount)
arrEmails(1, lngCount) = OutMail.entryid
arrEmails(2, lngCount) = CDate(OutMail.receivedtime)
'Save file to tempdir with new name
strFName = constABCInputFNameStub & lngCount & ".xls"
arrEmails(3, lngCount) = strFName
OutAttach.SaveAsFile strTempDir & "\" & strFName
End If
Next OutAttach
End If
'switch to next item
Set OutMail = OutItems.Getnext
Loop
This code previously worked, but suddenly I started getting an error as soon as the code accessed the Attachments in any way. Specifically, this line
If OutMail.Attachments.Count > 0 Then
Generates this error:
-2147221233 Method 'Attachments' of object 'MailItem' failed
I can access all of the MailItems, and almost all of their Properties, but for some reason it chokes on Attachments.
Changing from Late Binding to Early Binding made no difference, this is clearly an issue with Outlook.
I'm getting closer to the problem... I used to access the shared mailboxes through Outlook by going to the "File" menu, and choosing "Open", and then "Other User's Folder..." After doing that once, the mailbox then appears at the bottom of the File-Open menu.
However, this only gives you the Inbox, not the folders under it. So, last week, a collegue showed me how to add the shared Mailbox to my "All Mail Folders" list, by going to the "Tools" menu and selecting "Email Accounts..."
From there, you can edit your Exchange Server account. Under "More Settings", "Advanced", you can add the mailbox to the "Open these additional mailboxes" list. This makes the shared mailbox, and all of it's sub folders, appear in your Outlook list as normal.
However, that's when my code stops working. WTF!?!?!?!
Any guidance and/or work around would be greatly appreciated.
'**Set up Outlook objects
Set OutApp = CreateObject("Outlook.Application")
Set OutNS = OutApp.GetNameSpace("MAPI")
Set OutRecipient = OutNS.CreateRecipient(ABC_MailboxName)
Set OutFolder = OutNS.GetSharedDefaultFolder(OutRecipient, 6) 'olFolderInbox = 6
Set OutFolderManual = OutFolder.Folders("ABC Manual")
Set OutFolderErr = OutFolder.Folders("ABC Upload Errors")
'**Pull in Files from ABC:Inbox (Only correctly named files)
'Get Mailitems from Inbox
Set OutItems = OutFolder.Items
'restrict and sort items
Set OutItems = OutItems.Restrict("[MessageClass] = 'IPM.Note'")
OutItems.Sort "[Received]", False
'iterate through mailitems in inbox to find Mail Items with correctly named attachment
'copy to temp directory (in order)
lngCount = 0
'get first item
Set OutMail = OutItems.GetFirst
'begin loop
Do While TypeName(OutMail) <> "Nothing"
'branch on Attachments: if no attachments, skip to end
If OutMail.Attachments.Count > 0 Then
Set OutAttachments = OutMail.Attachments
For Each OutAttach In OutAttachments
If OutAttach.Filename = constABCInputFName Then
'increase count
lngCount = lngCount + 1
'Store Entry ID and Recieved date/time
ReDim Preserve arrEmails(1 To 3, 1 To lngCount)
arrEmails(1, lngCount) = OutMail.entryid
arrEmails(2, lngCount) = CDate(OutMail.receivedtime)
'Save file to tempdir with new name
strFName = constABCInputFNameStub & lngCount & ".xls"
arrEmails(3, lngCount) = strFName
OutAttach.SaveAsFile strTempDir & "\" & strFName
End If
Next OutAttach
End If
'switch to next item
Set OutMail = OutItems.Getnext
Loop
This code previously worked, but suddenly I started getting an error as soon as the code accessed the Attachments in any way. Specifically, this line
If OutMail.Attachments.Count > 0 Then
Generates this error:
-2147221233 Method 'Attachments' of object 'MailItem' failed
I can access all of the MailItems, and almost all of their Properties, but for some reason it chokes on Attachments.
Changing from Late Binding to Early Binding made no difference, this is clearly an issue with Outlook.
I'm getting closer to the problem... I used to access the shared mailboxes through Outlook by going to the "File" menu, and choosing "Open", and then "Other User's Folder..." After doing that once, the mailbox then appears at the bottom of the File-Open menu.
However, this only gives you the Inbox, not the folders under it. So, last week, a collegue showed me how to add the shared Mailbox to my "All Mail Folders" list, by going to the "Tools" menu and selecting "Email Accounts..."
From there, you can edit your Exchange Server account. Under "More Settings", "Advanced", you can add the mailbox to the "Open these additional mailboxes" list. This makes the shared mailbox, and all of it's sub folders, appear in your Outlook list as normal.
However, that's when my code stops working. WTF!?!?!?!
Any guidance and/or work around would be greatly appreciated.