Controlling Outlook through Excel

Sub SaveAttachments()

        ' This Outlook macro checks a the Outlook Inbox for messages
        ' with attached files (of any type) and saves them to disk.
        ' NOTE: make sure the specified save folder exists before
        ' running the macro.
        'On Error GoTo GetAttachments_err

        ' Declare variables
        Dim ns As Namespace
        Dim Item As Object
        Dim Inbox As MAPIFolder
        Dim fs
        Dim varResponse As VbMsgBoxResult
        Dim Atmt As Attachment
        Dim FileName As String
        Dim Ext As String
        Dim i As Integer
timelimit = Now - TimeValue("00:05:00")
        Set ns = CreateObject("Outlook.Application").GetNamespace("MAPI")
        Set fs = CreateObject("Scripting.FileSystemObject")
         Set Inbox = ns.GetDefaultFolder(olFolderInbox)
        'Inbox = ns.PickFolder
        i = 0
        ' Check Inbox for messages and exit of none found
        If Inbox.Items.Count = 0 Then
            MsgBox "There are no messages in the Inbox.", vbInformation, _
                   "Nothing Found"
            Exit Sub
        End If
        If fs.FolderExists(Environ("userprofile") & "\My Documents\My Email Attachments\") Then
        Else
            MkDir (Environ("userprofile") & "\My Documents\My Email Attachments\")
        End If
        For Each Item In Inbox.Items
 '       Debug.Print Item
 '     dd = Item.Subject
'
        If Item.ReceivedTime > timelimit And Item.Subject = "test" Then
            For Each Atmt In Item.Attachments
                ' Check filename of each attachment and save extension in sepreater folders

                Ext = LCase(Right(Atmt.FileName, Len(Atmt.FileName) - InStrRev(Atmt.FileName, ".")))

                If fs.FolderExists(Environ("userprofile") & "\My Documents\My Email Attachments\" & Ext & "\") Then
                Else
                    MkDir (Environ("userprofile") & "\My Documents\My Email Attachments\" & Ext & "\")
                End If


                ' This path must exist! Change folder name as necessary.
                FileName = Environ("userprofile") & "\My Documents\My Email Attachments\" & Ext & "\" & _
                    Format(Item.CreationTime, " yyyy.mm.dd_hh.mm ") & "( " & Item.SenderName & " )  " & Atmt.FileName
                '"( " & Item.SenderName & " ) " & Atmt.FileName
                'yyyy.mm.dd_hh.nn.ss

                Atmt.SaveAsFile (FileName)
                i = i + 1

            Next Atmt
            Else
            End If
        Next Item
        If i > 0 Then
            varResponse = MsgBox("I found " & i & " attached files." _
            & vbCrLf & "I have saved them into the My Documents\My Email Attachments\ folder." _
            & vbCrLf & vbCrLf & "Would you like to view the files now?" _
            , vbQuestion + vbYesNo, "Finished!")
            ' Open Windows Explorer to display saved files if user chooses
            If varResponse = vbYes Then
                Shell "Explorer.exe /e," & Environ("userprofile") & "\My Documents\My Email Attachments", vbNormalFocus
                'Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
            End If
        Else
            MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
        End If
        ' Show summary message
        '    If i > 0 Then
        '        MsgBox "I found " & i & " attached files." _
        '        & vbCrLf & "I have saved them into the My Documents\Email Attachments folder." _
        '        & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
        '    Else
        '        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
        '    End If
        ' Clear memory
GetAttachments_exit:
'to stop routine Call time
       'Call time
      
        Exit Sub
        ' Handle errors
'GetAttachments_err:
        MsgBox "An unexpected error has occurred." _
            & vbCrLf & "Please note and report the following information." _
            & vbCrLf & "Macro Name: GetAttachments" _
            & vbCrLf & "Error Number: " & Err.Number _
            & vbCrLf & "Error Description: " & Err.Description _
            , vbCritical, "Error!"
        Resume GetAttachments_exit
    End Sub

Sub time()
Application.OnTime Now + TimeValue("00:05:00"), "SaveAttachments"
End Sub

Sub time()
Debug.Print Now
Application.OnTime Now + TimeValue("00:05:00"), "SaveAttachments"
End Sub

Sub SaveAttachments()
Debug.Print Now
        ' This Outlook macro checks a the Outlook Inbox for messages
        ' with attached files (of any type) and saves them to disk.
        ' NOTE: make sure the specified save folder exists before
        ' running the macro.
        'On Error GoTo GetAttachments_err

        ' Declare variables
        Dim ns As Namespace
        Dim Item As Object
        Dim Inbox As MAPIFolder
        Dim fs
     
        Dim Atmt As Attachment
        Dim FileName As String


        Set ns = CreateObject("Outlook.Application").GetNamespace("MAPI")
        Set fs = CreateObject("Scripting.FileSystemObject")
         Set Inbox = ns.GetDefaultFolder(olFolderInbox)

        If Inbox.Items.Count = 0 Then
          
            Exit Sub
        End If
        If fs.FolderExists("C:\Attachments\") Then
        Else
            MkDir ("C:\Attachments\")
        End If
        timelimit = Now - TimeValue("00:05:00")
        
        For Each Item In Inbox.Items
        ' restricts to items less than 5 mins old and subject is "test"
        If Item.ReceivedTime > timelimit And Item.Subject = "test" Then
            For Each Atmt In Item.Attachments
                FileName = "C:\Attachments\" & Atmt.FileName
                Atmt.SaveAsFile (FileName)
            Next Atmt
        Else
        End If
        Next Item

GetAttachments_exit:
'to stop routine  comment out 'Call time below
       'Call time
      
        Exit Sub

        Resume GetAttachments_exit
    End Sub