Print Excel Attachments in an Outlook Folder

[Mister H]

Hi:

I am new to using VBA in Outlook. I have used it a lot in Excel but now I have a need for it in Outlook...

I am trying to assist someone in this office to try and make their repetitive job a little more automated. This person receives about 70 emails daily that have an Excel spreadsheet attached. What they do is:

-OPEN each individual email
-OPEN the Excel attachment
-PRINT the sheet titled "JOURNAL"
-CLOSE the Excel document
-CLOSE the email

They do this for ALL 70 emails received. I am wondering if there is a code that can be placed in Outlook that will Automatically Print Open all emails with in a folder titled "Print" and then automatically print ONLY the sheet titled Journal and then close the email.

I hope this makes sense to someone.

Any suggestions or advice would be GREATLY Appreciated.

Have a GREAT day,
Mark
:beerchug:

[JP2112]

You might have to tweak this slightly, and I didn't test it, but it should work:


' reuse Excel object so we don't have to instantiate it over and over
Dim xl As Excel.Application
Sub PrintEmails()
On Error GoTo ErrorHandler
Dim folder As Outlook.MAPIFolder
Dim itm As Object
Dim msg As Outlook.mailItem
Dim msgAttachments As Outlook.attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim fileName As String
' choose folder called "Print"
Set folder = Outlook.session.PickFolder
If folder Is Nothing Then GoTo ProgramExit
For Each itm In folder.Items
' is it an email?
If TypeName(itm) = "MailItem" Then
Set msg = itm
Set msgAttachments = msg.attachments
' does it have attachments?
If msgAttachments.Count > 0 Then
' check for Excel attachment
For Each msgAttach In msgAttachments
If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then
' save the attachment to temp folder
fileName = Environ("temp") & "\" & msgAttach.fileName
msgAttach.SaveAsFile fileName
' open the attachment
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(fileName)
Set xlwksht = xlwkbk.Sheets("JOURNAL")
' print worksheet
xlwksht.PrintOut
' close workbook
xlwkbk.Close False
' kill temp folder
Kill fileName
End If
Next msgAttach
End If
End If
Next itm
ProgramExit:
Set xl = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[Mister H]

THANKS for the reply. I am away from the office for a few days but will testit out as soon as I get back. I APPRECIATE your assistance.

The emails will be in a folder under the users name titled:

ADIs TO BE Printed

I was wondering if it is possible to move the emails with there attachmentafter they are printed to a folder titled:

ADIs TO BE Uploaded

The last step that I did not mention in my original post is that when theuser has printed the Excel attachment, verified and then uploaded them they arethen required to SAVE THE MESSAGES AS msg files in a folder on a shared drivetitled:

D:\NTR\ADIs COMPLETED

Do you know if Outlook is capable of doing that? Maybe I should be postingthat as a different post for that question? Anyway, I just thought I would askwhile it was fresh on my mind. I know ittakes the user quite a bit of time saving each individual file one at a time.

Have a GREAT day,
Mark
:beerchug:

[JP2112]

Re: saving emails

Right after "Next msgAttach", add this:

msg.SaveAs "D:\NTR\ADIs COMPLETED\" & msg.Subject & msg.ReceivedTime & ".msg"

Re: moving emails

This requires a different loop, since moving the emails will change the Items collection we need to loop backwards.

1- Add this to the top of the code:

Dim i As Long

2- Change this:

For Each itm In folder.Items
to this:

For i = folder.Items.Count To 1 Step -1

3- Change this:

Next itm

to this:

Next i

4- Change this:

TypeName(itm)

to this:

TypeName(folder.Items(i))

5- Change this:

Set msg = itm

to this:

Set msg = folder.Items(i)

6- Right after the "msg.SaveAs" line you added earlier, add this line:

msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("ADIs TO BE Uploaded")

I assume that "ADIs TO BE Uploaded" is one level below the default Inbox. If that is not the case, you need to point to the correct folder.

[Mister H]

THANKS for ALL your help JP. Your coding expertise is GREATLY Appreciated. Ican't wait to try it out next week when I return to the office. You will savingmy fellow employees a lot of time and aggravation.

I will post back with my final code (or MORE questions) after I test it out.Hopefully I can compile it as you have instructed.

I think the folder it is going to is a folder that they just created byhighlighting their user name and clicking add new folder. I don't believe it islocated within their inbox but I will confirm that when I return.

THANKS Again JP,
Have a GREAT day,
Mark

:beerchug:

[Mister H]

:hi:

Hi JP:

My apologies for not reporting back sooner but when since I returned to work it has been very chaotic and I am just getting an opportunity now to continue with this…

I tried the first code and it is not printing. When it gets to this section of code it is going to the End If without printing the Excel attachment. It goes directly to the End If section:

' check for Excel attachment
For Each msgAttach In msgAttachments
If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then

If I manually force it to go to the next section of code then it prints perfectly.

' save the attachment to temp folder
fileName = Environ("temp") & "\" & msgAttach.fileName
msgAttach.SaveAsFile filename

So for some reason it is not seeing the attachment as an Excel file?

ALSO, is there a way to mark the message as read after the attachment has been printed?

I have not yet had time to try out the altered code you gave me but I thought if possible I can present the person with two options and they can choose what will work best for them.

THANKS AGAIN for ALL your expertise JP,

I will report back when I try the altered version of your code.

Bye 4 Now,
Mark

[Mister H]

Hi JP:

I just tried altering the code but it still jumps past to End If as it does not recognize the file as an Excel Attachment. Just in case it matters...

When the code gets to

For Each msgAttach In msgAttachments

the file name is:
MAG - LTB - 3201 - LTB - Eastern - 03-Aug-2011 - $2,585.26.xls

When the code gets to

If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then

the filename is showing as:
MAG - LTB - 3201 - LTB - Eastern - 03-Aug-2011 - $2,5...

I am not sure on how to fix that.

Again if I forcibly step past

If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then

Then the Journal sheets prints but when I get to this line (I changed the save locations for testing purposes):

msg.SaveAs "C:\Test\ADIs\" & msg.Subject & msg.ReceivedTime & ".msg"

It automatically jumps to the error line:

MsgBox Err.Number & " - " & Err.Description

And I get the message:
- 936181757 - The operation failed.

The numbers seems to change every time I run it but it is always Operation Failed. eg it changed to 832372733

AGAIN, I am not sure of how to fix these errors. If you get time to check it out your EXPERTISE would be VERY much appreciated.

Have an AWESOME day JP,
Take Care,
Mark
:beerchug:
EDIT: SORRY here is the FULL Code:


' reuse Excel object so we don't have to instantiate it over and over
Dim xl As Excel.Application
Sub PrintEmails()
On Error GoTo ErrorHandler
Dim i As Long
Dim folder As Outlook.MAPIFolder
Dim itm As Object
Dim msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim fileName As String
'choose folder called "Print"
Set folder = Outlook.Session.PickFolder
If folder Is Nothing Then GoTo ProgramExit
For i = folder.Items.Count To 1 Step -1

'is it an email?
If TypeName(folder.Items(i)) = "MailItem" Then
Set msg = folder.Items(i)
Set msgAttachments = msg.Attachments

'does it have attachments?
If msgAttachments.Count > 0 Then

'check for Excel attachment
For Each msgAttach In msgAttachments
If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then

'save the attachment to temp folder
fileName = Environ("temp") & "\" & msgAttach.fileName
msgAttach.SaveAsFile fileName

'open the attachment
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(fileName)
Set xlwksht = xlwkbk.Sheets("JOURNAL")

'print worksheet
xlwksht.PrintOut

'close workbook
xlwkbk.Close False

'kill temp folder
Kill fileName
End If
Next msgAttach
'save the file as an msg file
msg.SaveAs "C:\Test\ADIs\" & msg.Subject & msg.ReceivedTime & ".msg"
msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("ADIs")
End If
End If
Next i
ProgramExit:
Set xl = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

[JP2112]

If you know the files are always .xls (i.e. pre-Excel 2007) then just hardcode the file extension like this:

Instead of

If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then

put:

If Right$(msgAttach.fileName, 3) = "xls" Then

You said this line was causing an error:

msg.SaveAs "C:\Test\ADIs\" & msg.Subject & msg.ReceivedTime & ".msg"

Are you checking that the path exists? What is the value of msg.Subject when the error occurs?

[Mister H]

Hi JP:

SORRY: msg.Subject = "MAG - LTB - 3201 - LTB - Eastern - 03-Aug-2011 - $2,585.26"

Just to clarify, I am trying to save the entire message not just the attachment



When I run the code the error message I got this time was:

Microsoft Office Outlook
-1767702441 - The operation failed.


THANKS,
Mark

I tried to insert the message as a bmp but I am not sure that it will show

http://www.vbaexpress.com/forum/C:\Documents and Settings\HugginM\My Documents\ERROR.bmp

Hi JP: SORRY I should also mention that it is not cuasing an error within VBA (not a Run Time Error) but it simply is not saving the email message as an msg file. Also, I have tow emails with excel attachments and when I run the code it is now printing the Jouranl page in the attachment (THANKS for the fix) but the code exits after I get the Ourlook Error Message. Also the path does exist. THANKS Again

[Mister H]

Hi JP:

My SINCERE APOLOGIES. I just reviewed your code and my folders and when I said the folder did exist it did in my C:\ Drive but NOT in my Outlook (I had modified the name :banghead: )

SO AFTER renaming the folder you code is working WONDERFULLY :yes

Again, sorry for the MY confusion. I may ask you for an alteration after presenting your GREAT Code to the user but I will let them get back to me on that.

For anyone trying to do something similar here is the final code (MAKE SURE the folders Exist in both Outlook and your own personal computer :banghead: ):


' reuse Excel object so we don't have to instantiate it over and over
Dim xl As Excel.Application

Sub PrintEmails()
On Error GoTo ErrorHandler
Dim i As Long
Dim folder As Outlook.MAPIFolder
Dim itm As Object
Dim msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim fileName As String
'choose folder called "Print"
Set folder = Outlook.Session.PickFolder
If folder Is Nothing Then GoTo ProgramExit
For i = folder.Items.Count To 1 Step -1

'is it an email?
If TypeName(folder.Items(i)) = "MailItem" Then
Set msg = folder.Items(i)
Set msgAttachments = msg.Attachments

'does it have attachments?
If msgAttachments.Count > 0 Then

'check for Excel attachment
For Each msgAttach In msgAttachments
If Right$(msgAttach.fileName, 3) = "xls" Then
'If Right(msgAttach.fileName, 3) = "xls" Then
'If Mid$(msgAttach.fileName, InStrRev(msgAttach.fileName, ".") - 1) Like "xls?" Then

'save the attachment to temp folder
fileName = Environ("temp") & "\" & msgAttach.fileName
msgAttach.SaveAsFile fileName

'open the attachment
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(fileName)
Set xlwksht = xlwkbk.Sheets("JOURNAL")

'print worksheet
xlwksht.PrintOut

'close workbook
xlwkbk.Close False

'kill temp folder
Kill fileName
End If
'Next msgAttach
'save the file as an msg file
'msg.SaveAs "C:\Test\ADIs COMPLETED\" & msg.Subject & msg.ReceivedTime & ".msg"
msg.SaveAs "C:\Test\ADIs COMPLETED\" & msg.Subject & ".msg"
msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("ADIs TO BE Uploaded")
Next msgAttach
End If
End If
Next i
ProgramExit:
Set xl = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

THANKS A MILLION JP,
Mark

[Mister H]

Hi JP:

The user asked me right away (of course) if there was a way to have the EMAIL SUBJECT line included somewhere in the printout?

It can be in the header or footer or anywhere.

I told them I would investigate but I am not sure if the code you gave me can be altered to do that or if I need to include it in my actual Excel Spreadsheet.

I am hoping Outlook can insert it on the printout.

THANKS AGAIN,
Mark
:beerchug:

[JP2112]

To put the email subject in the header put this right after "Set xlwksht = xlwkbk.Sheets("JOURNAL")"

xlwksht.PageSetup.CenterHeader = msg.Subject

[Mister H]

THANKS AGAIN JP. That works PERFECTLY :bow:

The only other thing the user is now mentioning as they may want to copy the messages as msg files using a separate macro. They said they would get back to me on that one. I am hoping that i can just remove that part of the code and paste it into another macro but I have not yet played around with that.

One last question: In Outlook can you assign keyboard shortcuts to macros? For example Ctrl + Shift + p to run the Print Macro?

Take Care,
Mark

[JP2112]

The only way to assign a shortcut key combination is to assign the macro to a toolbar button. See http://support.microsoft.com/kb/252427 for assistance.

[Mister H]

THANKS for EVERYTHING JP :friends:

Your EXPERTISE :bow: has been VERY much Appreciated.

I will give the article a read when I get a chance.

Have a GREAT day,
Mark
:beerchug:

[Mister H]

Hi JP:

I am butchering your code to separate the Save Messages as msg on the C Drive and the Print and Move messages.

Can you have a look when you have a chance and clean this up for me. I am pretty sure I probably have unnecessary coding in there. It seems to work but I don't want to mess up anyone’s Outlook so I thought I would ask the expert.

ALSO, how can I get the items to be marked as READ and go directly to the Deleted Items folder as opposed to the DELETE folder that I created in my Inbox?

Here is what I have:


Sub Save_Emails_As_MSG_Files()
'This macro will save the ADI Emails as msg files in a folder titled
'C:\Completed ADI Emails
On Error GoTo ErrorHandler
Dim i As Long
Dim folder As Outlook.MAPIFolder
Dim itm As Object
Dim Msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim fileName As String

'choose folder called "4) ADIs Completed"
'NOTE: You must create this folder within your Inbox
Set folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("4) ADIs Completed")
'OR
'Use this to allow the user to Select The Folder that contains the ADI Emails
'Set folder = Outlook.Session.PickFolder

If folder Is Nothing Then GoTo ProgramExit
For i = folder.Items.Count To 1 Step -1

'is it an email?
If TypeName(folder.Items(i)) = "MailItem" Then
Set Msg = folder.Items(i)
Set msgAttachments = Msg.Attachments

'save the file as an msg file to specified folder eg. C:\Test\ADIs COMPLETED
Msg.SaveAs "C:\ADIs COMPLETED\" & Msg.Subject & ".msg"
'move the email message to the specified folder
Msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("DELETE")

End If
Next i

ProgramExit:
Set xl = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub


THANKS for looking,
Have a GREAT weekend,
Mark

:beerchug:

[JP2112]

Does this project ever end? :rofl:

To mark the messages as read, add Msg.UnRead = False to your code. To delete the items, just move them to the default Deleted Items folder:

Outlook.Session.GetDefaultFolder(olFolderDeletedItems)

[Mister H]

Hi JP: :hi:

First off THANKS for sticking with the Post. Your help is VERY Much Appreciated. I SINCERELY HOPE (as you do) that this Project DOES END... :-) I think (term used loosely) that I see the FInish Line

I will implement the changes you provided. The last thing (Sorry I just noticed) I am having trouble with is that IF there is an email with the same subject line it does not save it more then once. I imagine that is because the file name is not unique. Can the code be made to save the file as with a number (1, 2 , 3 etc) after it if it already exists? I am using this code:


'save the file as an msg file to specified folder
'eg. C:\Test\ADIs COMPLETED
Msg.SaveAs "C:\ADIs COMPLETED\" & Msg.Subject & ".msg"



I did try a code from earlier in the post but it gives me an error.
-1490878377 - The operation failed. (the number seems to change each time the error pops up but the wording is the same). I was trying this code to add in the date:


Msg.SaveAs "C:\ADIs COMPLETED\" & Msg.Subject & Msg.ReceivedTime & ".msg"


THANKS AGAIN JP,
Have a GREAT day,
Mark

EDIT: SORRY I just tried the code save code on a file with the subject line:

FW: MAG - LTB - 8301 - LTB - Toronto East - 22-Sep-2011 - $3,260.00

It does not save the file as an msg file it just saves it as:

Name: FW
Size: 0 KB
Type: File

If a do a manual Save As I can save it as a msg file and the title is:
FW MAG - LTB - 8301 - LTB - Toronto East - 22-Sep-2011 - $3260.00.msg

Is there a fix for that as well? I don't really require the FW if that matters.

SORRY for the continued questions...

Take Care,
Mark

[Mister H]

Hi JP or anyone that is reading:

I have almost resolved my issue after reading many bits and pieces of posts using Google. I am hoping that someone can possibly help me finish this off.

I have added the seconds form the current time to TRY and give the file a unique name when it is saved. Unfortunately if I have 6 files with the same name in the folder when I run the macro only 4 are saved. I don't think the users of this code would face that scenario but i would like to make sure that NO FILES are Overwritten. I am suing this code to name the files:

'save the file as an msg file to the specified folder C:\ADIs COMPLETED
'filename will be the email Subject line (With character like :\/ removed via function
'also the seconds from the Current Time are being added to the end of the filename to
'try and make it unique (this is NOT GURANTEED - file MAY be overwritten)
Msg.SaveAs "C:\ADIs COMPLETED\" & CleanString(Msg.Subject) & " (" & Format(Time, "ss") & ")" & ".msg"


If someone can help me to make this more unique that would be awesome.

Regarding my problem of the file with the subject line that started with FW:
I resolved that by adding this function which removes the :

Function CleanString(StrInput As String)
Const BadChrs As String = ":\/" 'ADD whatever character you want to remove
Dim i As Integer
For i = 1 To Len(BadChrs)
StrInput = Replace(StrInput, Mid(BadChrs, i, 1), vbNullString)
Next
CleanString = StrInput
End Function


Now for anyone that MAY have the same sort of requirements that this whole Post was regarding here are the final codes I have which I assigned to Customized Buttons that I created on the Toolbar.


' reuse Excel object so we don't have to instantiate it over and over
Dim xl As Excel.Application
Sub Print_And_Move_ADI_Emails()
'This macro will Print the sheet titled "Journal" in the all of the attahced xls files
'within the folder titled:
'1) ADIs to be Printed
'Once it has printed them all emails will be moved to a folder titled:
'2) ADIs to be Verified
'NOTE: You must create BOTH of the above folders within your Outlook Inbox

On Error GoTo ErrorHandler
Dim i As Long
Dim folder As Outlook.MAPIFolder
Dim itm As Object
Dim Msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim fileName As String

'choose folder called "1) ADIs to be Printed"
'NOTE: You must create this folder within your Inbox
Set folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("1) ADIs to be Printed")

'OR
'Use this to allow the user to Select The Folder that contains the ADI Emails
'Set folder = Outlook.Session.PickFolder

If folder Is Nothing Then GoTo ProgramExit
For i = folder.Items.Count To 1 Step -1

'is it an email?
If TypeName(folder.Items(i)) = "MailItem" Then
Set Msg = folder.Items(i)
Set msgAttachments = Msg.Attachments

'does it have attachments?
If msgAttachments.Count > 0 Then

'check for Excel attachment
For Each msgAttach In msgAttachments
If Right$(msgAttach.fileName, 3) = "xls" Then

'save the attachment to temp folder
fileName = Environ("temp") & "\" & msgAttach.fileName
msgAttach.SaveAsFile fileName

'open the attachment
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(fileName)
Set xlwksht = xlwkbk.Sheets("JOURNAL")

'set up Header so that the Email Subject Line is the Header
xlwksht.PageSetup.CenterHeader = Msg.Subject

'print worksheet
xlwksht.PrintOut

'close workbook
xlwkbk.Close False

'kill temp folder
Kill fileName
End If
'move the email message to the specified folder
Msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("2) ADIs to be Verified")

'mark the email as Read
Msg.UnRead = False

Next msgAttach

End If
End If
Next i

ProgramExit:
Set xl = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit

End Sub
Sub Save_Emails_As_MSG_Files()
'This macro will save all the emails in a folder titled:
'4) ADIs Completed NOTE: Create this folder within your Outlook Inbox
'the files will be saved as msg files and saved to a folder on the c drive titled:
'C:\ADIs COMPLETED NOTE: Create this folder on your C:\ Drive
'The filename will be whatever the email Subject line is as well as adding to seconds from the current
'time to the end of the filename to TRY and make it unique (NOT GURANTEED)
'NOTE: You must make sure both of the above folders exists
On Error GoTo ErrorHandler
Dim i As Long
Dim folder As Outlook.MAPIFolder
Dim itm As Object
Dim Msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim fileName As String

'choose folder called "4) ADIs Completed"
'NOTE: You must create this folder within your Inbox
Set folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("4) ADIs Completed")

'OR
'Use this to allow the user to Select The Folder that contains the ADI Emails
'Set folder = Outlook.Session.PickFolder

If folder Is Nothing Then GoTo ProgramExit
For i = folder.Items.Count To 1 Step -1

'is it an email?
If TypeName(folder.Items(i)) = "MailItem" Then
Set Msg = folder.Items(i)
Set msgAttachments = Msg.Attachments



'save the file as an msg file to the specified folder C:\ADIs COMPLETED
'filename will be the email Subject line (With character like :\/ removed via function
'also the seconds from the Current Time are being added to the end of the filename to
'try and make it unique (this is NOT GURANTEED - file MAY be overwritten)
Msg.SaveAs "C:\ADIs COMPLETED\" & CleanString(Msg.Subject) & " (" & Format(Time, "ss") & ")" & ".msg"

'move the email message to the specified folder
'Msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("DELETE")
'OR
'move the email message to the Outlook Deleted Items folder
Msg.Move Outlook.Session.GetDefaultFolder(olFolderDeletedItems)

End If
Next i

ProgramExit:
Set xl = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit

End Sub
Function CleanString(StrInput As String)
Const BadChrs As String = ":\/" 'ADD whatever character you want to remove
Dim i As Integer
For i = 1 To Len(BadChrs)
StrInput = Replace(StrInput, Mid(BadChrs, i, 1), vbNullString)
Next
CleanString = StrInput
End Function



If anyone can assist in helping me set up a Sequence Number for the filename or revamp the codes so it WILL pop up a message stating that the File Already Exists and then allow the user to edit the filename or save that particular email manually that would be GREAT.

THANKS AGAIN to JP for ALL his EXPERTISE
Have an EXCELLENT day ALL,
Take Care,
Mark
:beerchug: