Moving email from one folder to another on shared inbox

Hi,

In outlook I have my inbox, as well as a shared inbox. I have some vba code to export emails from the shared inbox to a windows folder. That part works great. However the last part of the macro then deletes these emails. The issue is the macro is deleting the emails in the shared inbox and putting them into my inbox's deleted items instead of the the shared inbox deleted items. Im wondering if anyone can help me...Current code is:

' Deletes messages in folder
total_messages = objFolder.Items.Count
For i = 1 To total_messages
message_index = total_messages - i + 1
Set oMessage = objFolder.Items.Item(message_index)
oMessage.Delete
Set oMessage = Nothing
Next

Thanks!

Without access to your system it is difficult to be certain, but I think the following will work. The example below assumes that objFolder has been set to the shared inbox and with the Exit For line moves only one message.

Code:

---

Set olDelFolder = objFolder.Parent.folders("Deleted Items")
    For i = objFolder.Items.Count To 1 Step -1
        objFolder.Items.Item(i).Move olDelFolder
        Exit For 'Delete this line after testing
    Next i

---

Quote:

---

Originally Posted by gmayor

Without access to your system it is difficult to be certain, but I think the following will work. The example below assumes that objFolder has been set to the shared inbox and with the Exit For line moves only one message.

Code:

---

Set olDelFolder = objFolder.Parent.folders("Deleted Items")
    For i = objFolder.Items.Count To 1 Step -1
        objFolder.Items.Item(i).Move olDelFolder
        Exit For 'Delete this line after testing
    Next i

---

---

I get a run time error '-2147221233 (8004010f)': The attempted operation failed. An object could not be found for the first line. Any ideas? Here is the full macro:

Sub emailbody()

Dim myolApp As Outlook.Application
Dim aItem As Object
Set myolApp = CreateObject("Outlook.Application")
Set mail = myolApp.ActiveExplorer.CurrentFolder
Dim iItemsUpdated As Integer
Dim strTemp As String
Dim strFilenum As String
iItemsUpdated = 0
Dim xItem As Object
Dim xNewSubject As String
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim path As String
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetFirst ' folders of your current account
Set objFolder = objNS.Folders("Request") ' this is the shared inbox
Set objFolder = objFolder.Folders("Inbox")
Debug.Print (objFolder.Name)
Set objFolder = objFolder.Folders("Test2") ' subfolder.
Debug.Print (objFolder.Name)


For Each aItem In objFolder.Items

Dim mattcombine, mattyear, mattmonth, mattday As String
Dim i, j As Integer

i = InStr(2, aItem.ReceivedTime, "/")
j = InStr(i + 1, aItem.ReceivedTime, "/")

' MsgBox i & " and " & j

mattyear = Mid(aItem.ReceivedTime, j + 1, 4)
' MsgBox mattyear

mattmonth = Left(aItem.ReceivedTime, i - 1)
If Len(mattmonth) = 1 Then
mattmonth = "0" & mattmonth
End If
' MsgBox mattmonth

mattday = Mid(aItem.ReceivedTime, i + 1, j - i - 1)
' MsgBox mattday
If Len(mattday) = 1 Then
mattday = "0" & mattday
End If

' MsgBox mattyear & "-" & mattmonth & "-" & mattday
mattcombine = mattyear & "-" & mattmonth & "-" & mattday

' MsgBox mattcombine

Dim zachcombine, zachhour, zachminute, zachsecond, zacho As String
Dim z, q As Integer

z = InStr(2, aItem.ReceivedTime, ":")
q = InStr(z + 1, aItem.ReceivedTime, ":")

' MsgBox z & " and " & q

zachhour = Mid(aItem.ReceivedTime, z - 2, 2)

' MsgBox zachhour

Dim hourspace
hourspace = Left(zachhour, 1)
' MsgBox hourspace

If hourspace = " " Then
zachhour = zachhour
Else: zachhour = " " & zachhour
End If

' MsgBox zachhour

'Then
' zachhour = zachhour
' Else: zachhour = " " & zachhour
'End If

zachminute = Mid(aItem.ReceivedTime, z + 1, 2)
' MsgBox zachminute

zachsecond = Mid(aItem.ReceivedTime, q + 1, 2)
' MsgBox zachsecond

zacho = Mid(aItem.ReceivedTime, q + 4, 2)
' MsgBox zacho

zachcombine = zachhour & "-" & zachminute & "-" & zachsecond & " " & zacho
' MsgBox zachcombine

Dim zachpo As String
Dim a, b As Integer

a = InStr(aItem.Body, ",")
b = InStr(a + 1, aItem.Body, ",")

' MsgBox a & " and " & b

zachpo = Mid(aItem.Body, a + 1, b - a - 1)

' MsgBox zachpo

' Removes special characters
Set xMailItem = aItem
With xMailItem
xNewSubject = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Rep lace(Replace(.Subject, "/", ""), ":", ""), ".", ""), "*", "") _
, "|", ""), "", ""), "<", ""), ">", ""), "?", ""), ",", ""), Chr(34), "")
.Subject = xNewSubject
.Save
End With

' Exports
If TypeName(aItem) = "MailItem" Then
' ... do stuff here ...
path = "C:\Users\XXXXXXXXX\Desktop\23" & aItem.Subject & " PO" & zachpo & " " & mattcombine & zachcombine & ".msg"
aItem.SaveAs (path)
'Debug.Print Item.ConversationTopic
End If
Next
' Deletes messages in folder
Set olDelFolder = objFolder.Parent.Folders("Deleted Items")
For i = objFolder.Items.Count To 1 Step -1
objFolder.Items.Item(i).Move olDelFolder
Exit For 'Delete this line after testing
Next i
End Sub

Assuming that your code correctly identifies the location of objFolder as a subfolder of your shared inbox, then the code I posted cannot work as the parent folder of that sub folder is Inbox and that doesn't have a sub folder "Deleted Items". What you need then is to go up a level to the root folder e.g.

Code:

---

Set olDelFolder = objFolder.Parent.Parent.Folders("Deleted Items")

---

Don't forget to declare the olDelFolder at the top of the macro as an Outlook.MAPIFolder.
Again without access to your system and how it is configured, it looks as though you have the shared inbox as a sub folder of your default account and not as a separate account, which is why the deleted items are going into the default deleted items folder, as indeed I suspect does this modification.