Consulting

Results 1 to 7 of 7

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

  1. #1

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

    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



  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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
    Last edited by therion17; 04-11-2019 at 10:56 AM.

  4. #4
    Quote Originally Posted by gmayor View Post
    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.
    Last edited by therion17; 04-11-2019 at 11:11 AM.

  5. #5
    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


  6. #6
    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
    Last edited by gmayor; 04-11-2019 at 11:16 PM.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •