I was able to get it working and even configured it torun through all the items in whatever folder I have selected. Thanks again foryour help gmayor!










	
Public Sub RunTest ()


Dim objOL As Outlook.Application


Dim objItems As Outlook.Items


Dim objFolder As Outlook.MAPIFolder


Dim obj As Object





Set objOL = Outlook.Application


Set objFolder =objOL.ActiveExplorer.CurrentFolder


Set objItems = objFolder.Items





For Each obj In objItems


With obj


Call Test (obj)


End With


Next





Set obj = Nothing


Set objItems = Nothing


Set objFolder = Nothing


Set objOL = Nothing


MsgBox "All attachments have beenextracted"





End Sub





Public Sub Test (mItem AsOutlook.MailItem)


Dim oAttachment AsOutlook.Attachment


Const sSaveFolder1 As String = "C:\Test1\"
ConstsSaveFolder2 As String = "C:\Test2\"
ConstsSaveFolder3 As String = "C:\Test3\"
ConstsSaveFolder4 As String = "C:\Test4\"
ConstsSaveFolder5 As String = "C:\Test5\"
ConstsSaveFolder6 As String = "C:\Test6\"
ConstsSaveFolder7 As String = "C:\Test7\"
ConstsSaveFolder8 As String = "C:\Test8\"
ConstsSaveFolder9 As String = "C:\Test9\"
ConstsSaveFolder10 As String = "C:\Test10\"
ConststrText1 As String = "Test String 1"
ConststrText2 As String = "Test String 2"
ConststrText3 As String = "Test String 3"
ConststrText4 As String = "Test String 4"
ConststrText5 As String = "Test String 5"
ConststrText6 As String = "Test String 6"
ConststrText7 As String = "Test String 7"
ConststrText8 As String = "Test String 8"
ConststrText9 As String = "Test String 9"
ConststrText10 As String = "Test String 10"


For Each oAttachment In mItem.Attachments


If InStr(1, oAttachment.FileName,strText1) > 0 Then


oAttachment.SaveAsFile sSaveFolder1& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText2) > 0 Then


oAttachment.SaveAsFile sSaveFolder2& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText3) > 0 Then


oAttachment.SaveAsFile sSaveFolder3& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText4) > 0 Then


oAttachment.SaveAsFile sSaveFolder4 &oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText5) > 0 Then


oAttachment.SaveAsFile sSaveFolder5& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText6) > 0 Then


oAttachment.SaveAsFile sSaveFolder6& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText7) > 0 Then


oAttachment.SaveAsFile sSaveFolder7& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText8) > 0 Then


oAttachment.SaveAsFile sSaveFolder8& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText9) > 0 Then


oAttachment.SaveAsFile sSaveFolder9& oAttachment.FileName


End If


If InStr(1, oAttachment.FileName,strText10) > 0 Then


oAttachment.SaveAsFilesSaveFolder10 & oAttachment.FileName


End If


Next oAttachment


Set oAttachment = Nothing





End Sub