I need to be able to select a mail item in my inbox, make a copy of it and
move the original to a folder named "Saved Mail" and move the copy to a
folder named "Copied Mail". The only way I've been sucessful doing this is
to create two separate macros (see my provided code) which I created after
searching the newgroup for help.

I was hoping someone can help me combine the code into one macro.

Thanks.

Sub copy()
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Dim objReport As Outlook.ReportItem

Set objNS = Application.GetNamespace("MAPI")

Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Saved Mail")
'Assume this is a mail folder

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If

'Make copy of mail item
Set objOrig = Application.ActiveExplorer.Selection.Item(1)
Set objCopy = objOrig.copy
' objCopy.copy

For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.move objFolder
End If
End If
Next

For Each objReport In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objReport.move objFolder
End If
End If
Next

Set objItem = Nothing
Set objReport = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

Sub copy1()
On Error Resume Next

Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS1 As Outlook.NameSpace
Dim objItem1 As Outlook.MailItem
Dim objReport1 As Outlook.ReportItem

Set objNS1 = Application.GetNamespace("MAPI")

Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Copied Mail")
'Assume this is a mail folder

If objFolder1 Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If

For Each objItem1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objItem1.move objFolder1
End If
End If
Next

For Each objReport1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objReport1.move objFolder1
End If
End If
Next

Set objItem1 = Nothing
Set objReport1 = Nothing
Set objFolder1 = Nothing
Set objInbox1 = Nothing
Set objNS1 = Nothing

End Sub

Am Wed, 20 Sep 2006 07:39:03 -0700 schrieb LDMueller:

Please compare the code yourself line for line: The only things wich are
different are the target folders.

So actually we need to discuss one sample only. But there´re a few bugs in
it:

1) If objFolder is Nothing you should leave the procedure after displaying
the MsgBox - like you do it if Selection.Count is 0.

2) In your sample you copy only the first selected item but then try to move
all selected items.

3) Because the mail folder could contain different objects you must not use
objItem (MailItem) or objReport (ReportItem) to loop through it, but a
generic object. sample:

Dim obj as Object
Dim i as Long
Dim Sel as Selection
Set Sel=Application.ActiveExplorer.Selection
For i=Sel.Count To 1 Step -1
Set obj=Sel(i)
Select Case True
Case (TypeOf obj is Outlook.MailItem), (TypeOf obj is Outlook.ReportItem)
Set objCopy=obj.Copy
obj.Move Folder1
objCopy.Move Folder2
End Select
Next

4) The sample shows another issue: If you move items out off a list the loop
must count backwards.

By using a generic object you don´t need to differ between MailItems and
ReportItems.

5) The check, whether or not objFolder1.DefaultItemType is olMailItem, could
be done right after realizing that objFolder1 is not nothing. Because the
object doesn´t change it isn´t necessary to check that for each selected
item again and again.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --


I need to be able to select a mail item in my inbox, make a copy of it and
move the original to a folder named "Saved Mail" and move the copy to a
folder named "Copied Mail". The only way I've been sucessful doing this
is
to create two separate macros (see my provided code) which I created after
searching the newgroup for help.

I was hoping someone can help me combine the code into one macro.

Thanks.

Sub copy()
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Dim objReport As Outlook.ReportItem

Set objNS = Application.GetNamespace("MAPI")

Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Saved Mail")
'Assume this is a mail folder

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

'Make copy of mail item
Set objOrig = Application.ActiveExplorer.Selection.Item(1)
Set objCopy = objOrig.copy
' objCopy.copy

For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.move objFolder
End If
End If
Next

For Each objReport In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objReport.move objFolder
End If
End If
Next

Set objItem = Nothing
Set objReport = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

Sub copy1()
On Error Resume Next

Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS1 As Outlook.NameSpace
Dim objItem1 As Outlook.MailItem
Dim objReport1 As Outlook.ReportItem

Set objNS1 = Application.GetNamespace("MAPI")

Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Copied Mail")
'Assume this is a mail folder

If objFolder1 Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

For Each objItem1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objItem1.move objFolder1
End If
End If
Next

For Each objReport1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objReport1.move objFolder1
End If
End If
Next

Set objItem1 = Nothing
Set objReport1 = Nothing
Set objFolder1 = Nothing
Set objInbox1 = Nothing
Set objNS1 = Nothing

End Sub

Okay, this works beautifully and I truly thank you for your detail since I'm
limited as to what code I can read and write. I do have one more part to
this puzzle.

The folders I'm actually moving and copying the mail to reside in an
additional mailbox which I have opened from my mailbox. The folders in this
other mailbox have been added to my Favorites Folders.

Can you direct me as to how I can move and copy the mail into these folders?

Thanks!

Sub Move()
Dim obj As Object
Dim i As Long
Dim Sel As Selection

Dim objFolder As Outlook.MAPIFolder
Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objNS1 As Outlook.NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set objNS1 = Application.GetNamespace("MAPI")

'Assume these are mail folders
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Assign Ticket")
Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Saved Mail")

Set Sel = Application.ActiveExplorer.Selection
For i = Sel.Count To 1 Step -1
Set obj = Sel(i)
Select Case True
Case (TypeOf obj Is Outlook.MailItem), (TypeOf obj Is
Outlook.ReportItem)
Set objCopy = obj.copy
obj.Move objFolder
objCopy.Move objFolder1
End Select
Next
End Sub


"Michael Bauer [MVP - Outlook]" wrote:

Am Wed, 20 Sep 2006 07:39:03 -0700 schrieb LDMueller:

Please compare the code yourself line for line: The only things wich are
different are the target folders.

So actually we need to discuss one sample only. But there´re a few bugs in
it:

1) If objFolder is Nothing you should leave the procedure after displaying
the MsgBox - like you do it if Selection.Count is 0.

2) In your sample you copy only the first selected item but then try to move
all selected items.

3) Because the mail folder could contain different objects you must not use
objItem (MailItem) or objReport (ReportItem) to loop through it, but a
generic object. sample:

Dim obj as Object
Dim i as Long
Dim Sel as Selection
Set Sel=Application.ActiveExplorer.Selection
For i=Sel.Count To 1 Step -1
Set obj=Sel(i)
Select Case True
Case (TypeOf obj is Outlook.MailItem), (TypeOf obj is Outlook.ReportItem)
Set objCopy=obj.Copy
obj.Move Folder1
objCopy.Move Folder2
End Select
Next

4) The sample shows another issue: If you move items out off a list the loop
must count backwards.

By using a generic object you don´t need to differ between MailItems and
ReportItems.

5) The check, whether or not objFolder1.DefaultItemType is olMailItem, could
be done right after realizing that objFolder1 is not nothing. Because the
object doesn´t change it isn´t necessary to check that for each selected
item again and again.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --


I need to be able to select a mail item in my inbox, make a copy of it and
move the original to a folder named "Saved Mail" and move the copy to a
folder named "Copied Mail". The only way I've been sucessful doing this
is
to create two separate macros (see my provided code) which I created after
searching the newgroup for help.

I was hoping someone can help me combine the code into one macro.

Thanks.

Sub copy()
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Dim objReport As Outlook.ReportItem

Set objNS = Application.GetNamespace("MAPI")

Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Saved Mail")
'Assume this is a mail folder

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

'Make copy of mail item
Set objOrig = Application.ActiveExplorer.Selection.Item(1)
Set objCopy = objOrig.copy
' objCopy.copy

For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.move objFolder
End If
End If
Next

For Each objReport In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objReport.move objFolder
End If
End If
Next

Set objItem = Nothing
Set objReport = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

Sub copy1()
On Error Resume Next

Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS1 As Outlook.NameSpace
Dim objItem1 As Outlook.MailItem
Dim objReport1 As Outlook.ReportItem

Set objNS1 = Application.GetNamespace("MAPI")

Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Copied Mail")
'Assume this is a mail folder

If objFolder1 Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

For Each objItem1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objItem1.move objFolder1
End If
End If
Next

For Each objReport1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objReport1.move objFolder1
End If
End If
Next

Set objItem1 = Nothing
Set objReport1 = Nothing
Set objFolder1 = Nothing
Set objInbox1 = Nothing
Set objNS1 = Nothing

End Sub

Am Thu, 21 Sep 2006 06:18:02 -0700 schrieb LDMueller:

You did it already: You can get any opened folder by walking through the
object hierarchy, ie. the Folders.Item and Mapifolder.Parent properties.

Another way is using this sample:
www.outlookcode.com/d/code/getfolder.htm

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --


Okay, this works beautifully and I truly thank you for your detail since
I'm
limited as to what code I can read and write. I do have one more part to
this puzzle.

The folders I'm actually moving and copying the mail to reside in an
additional mailbox which I have opened from my mailbox. The folders in
this
other mailbox have been added to my Favorites Folders.

Can you direct me as to how I can move and copy the mail into these
folders?

Thanks!

Sub Move()
Dim obj As Object
Dim i As Long
Dim Sel As Selection

Dim objFolder As Outlook.MAPIFolder
Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objNS1 As Outlook.NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set objNS1 = Application.GetNamespace("MAPI")

'Assume these are mail folders
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Assign Ticket")
Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Saved Mail")

Set Sel = Application.ActiveExplorer.Selection
For i = Sel.Count To 1 Step -1
Set obj = Sel(i)
Select Case True
Case (TypeOf obj Is Outlook.MailItem), (TypeOf obj Is
Outlook.ReportItem)
Set objCopy = obj.copy
obj.Move objFolder
objCopy.Move objFolder1
End Select
Next
End Sub


"Michael Bauer [MVP - Outlook]" wrote:

Am Wed, 20 Sep 2006 07:39:03 -0700 schrieb LDMueller:

Please compare the code yourself line for line: The only things wich are
different are the target folders.

So actually we need to discuss one sample only. But there´re a few bugs
in
it:

1) If objFolder is Nothing you should leave the procedure after
displaying
the MsgBox - like you do it if Selection.Count is 0.

2) In your sample you copy only the first selected item but then try to
move
all selected items.

3) Because the mail folder could contain different objects you must not
use
objItem (MailItem) or objReport (ReportItem) to loop through it, but a
generic object. sample:

Dim obj as Object
Dim i as Long
Dim Sel as Selection
Set Sel=Application.ActiveExplorer.Selection
For i=Sel.Count To 1 Step -1
Set obj=Sel(i)
Select Case True
Case (TypeOf obj is Outlook.MailItem), (TypeOf obj is
Outlook.ReportItem)
Set objCopy=obj.Copy
obj.Move Folder1
objCopy.Move Folder2
End Select
Next

4) The sample shows another issue: If you move items out off a list the
loop
must count backwards.

By using a generic object you don´t need to differ between MailItems and
ReportItems.

5) The check, whether or not objFolder1.DefaultItemType is olMailItem,
could
be done right after realizing that objFolder1 is not nothing. Because the
object doesn´t change it isn´t necessary to check that for each selected
item again and again.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --


I need to be able to select a mail item in my inbox, make a copy of it
and
move the original to a folder named "Saved Mail" and move the copy to a
folder named "Copied Mail". The only way I've been sucessful doing this
is
to create two separate macros (see my provided code) which I created
after
searching the newgroup for help.

I was hoping someone can help me combine the code into one macro.

Thanks.

Sub copy()
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Dim objReport As Outlook.ReportItem

Set objNS = Application.GetNamespace("MAPI")

Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Saved Mail")
'Assume this is a mail folder

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

'Make copy of mail item
Set objOrig = Application.ActiveExplorer.Selection.Item(1)
Set objCopy = objOrig.copy
' objCopy.copy

For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.move objFolder
End If
End If
Next

For Each objReport In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objReport.move objFolder
End If
End If
Next

Set objItem = Nothing
Set objReport = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

Sub copy1()
On Error Resume Next

Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS1 As Outlook.NameSpace
Dim objItem1 As Outlook.MailItem
Dim objReport1 As Outlook.ReportItem

Set objNS1 = Application.GetNamespace("MAPI")

Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Copied Mail")
'Assume this is a mail folder

If objFolder1 Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

For Each objItem1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objItem1.move objFolder1
End If
End If
Next

For Each objReport1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objReport1.move objFolder1
End If
End If
Next

Set objItem1 = Nothing
Set objReport1 = Nothing
Set objFolder1 = Nothing
Set objInbox1 = Nothing
Set objNS1 = Nothing

End Sub

Perfect. I'm truly grateful for this information.

Thanks Michael!

Leigh

"Michael Bauer [MVP - Outlook]" wrote:

Am Thu, 21 Sep 2006 06:18:02 -0700 schrieb LDMueller:

You did it already: You can get any opened folder by walking through the
object hierarchy, ie. the Folders.Item and Mapifolder.Parent properties.

Another way is using this sample:
www.outlookcode.com/d/code/getfolder.htm

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --


Okay, this works beautifully and I truly thank you for your detail since
I'm
limited as to what code I can read and write. I do have one more part to
this puzzle.

The folders I'm actually moving and copying the mail to reside in an
additional mailbox which I have opened from my mailbox. The folders in
this
other mailbox have been added to my Favorites Folders.

Can you direct me as to how I can move and copy the mail into these
folders?

Thanks!

Sub Move()
Dim obj As Object
Dim i As Long
Dim Sel As Selection

Dim objFolder As Outlook.MAPIFolder
Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objNS1 As Outlook.NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set objNS1 = Application.GetNamespace("MAPI")

'Assume these are mail folders
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Assign Ticket")
Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Saved Mail")

Set Sel = Application.ActiveExplorer.Selection
For i = Sel.Count To 1 Step -1
Set obj = Sel(i)
Select Case True
Case (TypeOf obj Is Outlook.MailItem), (TypeOf obj Is
Outlook.ReportItem)
Set objCopy = obj.copy
obj.Move objFolder
objCopy.Move objFolder1
End Select
Next
End Sub


"Michael Bauer [MVP - Outlook]" wrote:

Am Wed, 20 Sep 2006 07:39:03 -0700 schrieb LDMueller:

Please compare the code yourself line for line: The only things wich are
different are the target folders.

So actually we need to discuss one sample only. But there´re a few bugs
in
it:

1) If objFolder is Nothing you should leave the procedure after
displaying
the MsgBox - like you do it if Selection.Count is 0.

2) In your sample you copy only the first selected item but then try to
move
all selected items.

3) Because the mail folder could contain different objects you must not
use
objItem (MailItem) or objReport (ReportItem) to loop through it, but a
generic object. sample:

Dim obj as Object
Dim i as Long
Dim Sel as Selection
Set Sel=Application.ActiveExplorer.Selection
For i=Sel.Count To 1 Step -1
Set obj=Sel(i)
Select Case True
Case (TypeOf obj is Outlook.MailItem), (TypeOf obj is
Outlook.ReportItem)
Set objCopy=obj.Copy
obj.Move Folder1
objCopy.Move Folder2
End Select
Next

4) The sample shows another issue: If you move items out off a list the
loop
must count backwards.

By using a generic object you don´t need to differ between MailItems and
ReportItems.

5) The check, whether or not objFolder1.DefaultItemType is olMailItem,
could
be done right after realizing that objFolder1 is not nothing. Because the
object doesn´t change it isn´t necessary to check that for each selected
item again and again.

--
Viele Gruesse / Best regards
Michael Bauer - MVP Outlook
-- www.VBOffice.net --


I need to be able to select a mail item in my inbox, make a copy of it
and
move the original to a folder named "Saved Mail" and move the copy to a
folder named "Copied Mail". The only way I've been sucessful doing this
is
to create two separate macros (see my provided code) which I created
after
searching the newgroup for help.

I was hoping someone can help me combine the code into one macro.

Thanks.

Sub copy()
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder
Dim objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.MailItem
Dim objReport As Outlook.ReportItem

Set objNS = Application.GetNamespace("MAPI")

Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Saved Mail")
'Assume this is a mail folder

If objFolder Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

'Make copy of mail item
Set objOrig = Application.ActiveExplorer.Selection.Item(1)
Set objCopy = objOrig.copy
' objCopy.copy

For Each objItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.move objFolder
End If
End If
Next

For Each objReport In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objReport.move objFolder
End If
End If
Next

Set objItem = Nothing
Set objReport = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

Sub copy1()
On Error Resume Next

Dim objFolder1 As Outlook.MAPIFolder
Dim objInbox1 As Outlook.MAPIFolder
Dim objNS1 As Outlook.NameSpace
Dim objItem1 As Outlook.MailItem
Dim objReport1 As Outlook.ReportItem

Set objNS1 = Application.GetNamespace("MAPI")

Set objInbox1 = objNS1.GetDefaultFolder(olFolderInbox)
Set objFolder1 = objInbox1.Parent.Folders("Copied Mail")
'Assume this is a mail folder

If objFolder1 Is Nothing Then
MsgBox "This folder doesn't exist!", vbOKOnly + vbExclamation, _
"INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is
selected
Exit Sub
End If

For Each objItem1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objItem1.move objFolder1
End If
End If
Next

For Each objReport1 In Application.ActiveExplorer.Selection
If objFolder1.DefaultItemType = olMailItem Then
If objItem1.Class = olMail Then
objReport1.move objFolder1
End If
End If
Next

Set objItem1 = Nothing
Set objReport1 = Nothing
Set objFolder1 = Nothing
Set objInbox1 = Nothing
Set objNS1 = Nothing

End Sub