Combine 2 scripts into 1 and make the script callable in the macro table

[therion17]

Hi, below I have two scripts that comb through an emailinbox and download attachments with specific key words in the attachment name.I would like to combine these into one so that the code runs through the inboxlooking for "Test String 1" and then goes and looks for "TestString 2." I would also like this script to be callable as macro. As itstands this script can only be attached to a rule (and not callable as a macro)because it has arguments.
Thank you for the help!

---------------------------------------------------------------------------------------------------------------------
Public Sub Test 1 (mItem As Outlook.MailItem)

Dim oAttachment As Outlook.Attachment

Dim sSaveFolder As String
Dim strText As String
strText = "Teststring 1"
sSaveFolder =" C:\Test"
For EachoAttachment In mItem.Attachments
If InStr(1,oAttachment.FileName, strText) > 0 Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
End If
Next oAttachment
Set oAttachment =Nothing

End Sub
-------------------------------------------------------------------------------------------------------------------------------------


Public Sub Test 2 (mItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim strText As String
strText = "Teststring 2"
sSaveFolder =" C:\Test2"
For EachoAttachment In mItem.Attachments
If InStr(1,oAttachment.FileName, strText) > 0 Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
End If
Next oAttachment
Set oAttachment =Nothing
End Sub

[gmayor]

Simple enough


Sub RunTest()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
Test olMsg
lbl_Exit:
Exit Sub
End Sub

Public Sub Test(mItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Const sSaveFolder1 As String = "C:\Test\"
Const sSaveFolder2 As String = "C:\Test2\"
Const strText1 As String = "Teststring 1"
Const strText2 As String = "Teststring 2"

For Each oAttachment In mItem.Attachments
If InStr(1, oAttachment.fileName, strText1) > 0 Then
oAttachment.SaveAsFile sSaveFolder2 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText2) > 0 Then
oAttachment.SaveAsFile sSaveFolder2 & oAttachment.fileName
End If
Next oAttachment
Set oAttachment = Nothing
End Sub

[therion17]

Thanks for your help gmayor!


So I took your code and added a few more checks. Howeverwhen I run the macro it looks like nothing happens. I'll select all the itemsin the folder and then run the macro but it doesn't save the specifiedattachments (and doesn't even look like it runs at all). Did I incorrectly addin the other items?
---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub RunTest()
Dim olMsg As MailItem
On Error ResumeNext
Set olMsg =ActiveExplorer.Selection.Item(1)
Test olMsg
lbl_Exit:
Exit Sub
End Sub

Public Sub Test(mItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Const sSaveFolder1 As String = "C:\Test1"
Const sSaveFolder2 As String = "C:\Test2"
Const sSaveFolder3 As String = "C:\Test3"
Const sSaveFolder4 As String = "C:\Test4"
Const sSaveFolder5 As String = "C:\Test5"
Const sSaveFolder6 As String = "C:\Test6"
Const sSaveFolder7 As String = "C:\Test7"
Const sSaveFolder8 As String = "C:\Test8"
Const sSaveFolder9 As String = "C:\Test9"
Const sSaveFolder10 As String = "C:\Test10"
Const strText1 As String = "Test String 1"
Const strText2 As String = "Test String 2"
Const strText3 As String = "Test String 3"
Const strText4 As String = "Test String 4"
Const strText5 As String = "Test String 5"
Const strText6 As String = "Test String 6"
Const strText7 As String = "Test String 7"
Const strText8 As String = "Test String 8"
Const strText9 As String = "Test String 9"
Const strText10 As String = "Test String 10"

For EachoAttachment 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.SaveAsFile sSaveFolder10 & oAttachment.FileName
End If
NextoAttachment
Set oAttachment= Nothing
End Sub

[therion17]

Simple enough


Sub RunTest()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
Test olMsg
lbl_Exit:
Exit Sub
End Sub

Public Sub Test(mItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Const sSaveFolder1 As String = "C:\Test\"
Const sSaveFolder2 As String = "C:\Test2\"
Const strText1 As String = "Teststring 1"
Const strText2 As String = "Teststring 2"

For Each oAttachment In mItem.Attachments
If InStr(1, oAttachment.fileName, strText1) > 0 Then
oAttachment.SaveAsFile sSaveFolder2 & oAttachment.fileName
End If
If InStr(1, oAttachment.fileName, strText2) > 0 Then
oAttachment.SaveAsFile sSaveFolder2 & oAttachment.fileName
End If
Next oAttachment
Set oAttachment = Nothing
End Sub


I also did try to run your version and I'm having trouble getting it to run.

[therion17]

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

[gmayor]

Your code works fine - however
1. You keep losing spaces in statements that you have posted
2. The paths need to be terminated with a backslash character or they become part of the filename.
3. The paths must exist, so I have added code to create them when missing.
4. The string to search for must be EXACTLY as entered in the filename and not some variation of it. For mixed case you would need e.g.
If InStr(1, LCase(oAttachment.fileName), LCase(strText1)) > 0 Then



Option Explicit


Sub RunTest()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
Test olMsg
lbl_Exit:
Exit Sub
End Sub

Public Sub Test(mItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim lngFldr As Long
Const sSaveFolder1 As String = "C:\Test1\"
Const sSaveFolder2 As String = "C:\Test2\"
Const sSaveFolder3 As String = "C:\Test3\"
Const sSaveFolder4 As String = "C:\Test4\"
Const sSaveFolder5 As String = "C:\Test5\"
Const sSaveFolder6 As String = "C:\Test6\"
Const sSaveFolder7 As String = "C:\Test7\"
Const sSaveFolder8 As String = "C:\Test8\"
Const sSaveFolder9 As String = "C:\Test9\"
Const sSaveFolder10 As String = "C:\Test10\"
Const strText1 As String = "Test String 1"
Const strText2 As String = "Test String 2"
Const strText3 As String = "Test String 3"
Const strText4 As String = "Test String 4"
Const strText5 As String = "Test String 5"
Const strText6 As String = "Test String 6"
Const strText7 As String = "Test String 7"
Const strText8 As String = "Test String 8"
Const strText9 As String = "Test String 9"
Const strText10 As String = "Test String 10"

For lngFldr = 1 To 10
CreateFolders "C:\Test" & lngFldr & "\"
Next lngFldr

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.SaveAsFile sSaveFolder10 & oAttachment.fileName
End If
Next oAttachment
Set oAttachment = Nothing
End Sub

Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & VPath(2) & "\"
For lngPath = 3 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
Else
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lngPath
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function

[therion17]

Awesome, you were right the issue I was having was I just forgot the back slash at the end of the
of the file paths. Thank you so much for your help! And yes I've noticed that when pasting code into the message box I lose some spaces for whatever reason.