Outlook 2007. Save attachment 2 times. Once to specific location, again to user-designated folder.

Sub savetwo(mai As Object)
Dim strIdent As String
Dim bolRetry As Boolean
Dim strQualifier As String
Dim fso As Object
Dim strFileSpec As String

    If TypeName(mai) <> "MailItem" Then
        MsgBox "Aborting Loop as incorrect object type supplied"
        Exit Sub
    End If
    If mai.Attachments.Count = 0 Then
        MsgBox "Aborting Loop as no attachments found for the supplied object"
        Exit Sub
    End If
    bolRetry = True
    Do While bolRetry
        strIdent = InputBox(strQualifier & "Enter the Series Identifier :>", "User Prompt")
        If strIdent = "" Then
            MsgBox "Aborting Loop with a null input"
            Exit Sub
        ElseIf Len(strIdent) < 4 Or Len(strIdent) > 4 Then
            strQualifier = "Input length incorrect" & vbCrLf & vbCrLf
        ElseIf Not IsNumeric(strIdent) Then
            strQualifier = "Input must be numeric" & vbCrLf & vbCrLf
        Else
            bolRetry = False
        End If
    Loop
    strFileSpec = "\\MyBigFolder\MyLittleFolder\" & strIdent & "\"
    md strFileSpec, True
    strFileSpec = strFileSpec & mai.Attachments(1).filename
    
    mai.Attachments(1).SaveAsFile strFileSpec
    
Set fso = Nothing
End Sub

Function md(dosPath As String, Optional createFolders As Boolean)
' Modified to account for UNC paths
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
Dim arr() As String
Dim elem As Integer
Dim strFilePath As String
    
    md = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        If Left(dosPath, 2) = "\\" Then
            dosPath = Right(dosPath, Len(dosPath) - 2)
            fldrs = Split(dosPath, "\")
            fldrs(0) = "\\" & fldrs(0)
        Else
            fldrs = Split(dosPath, "\")
        End If
        If UBound(fldrs) = 1 Then
            md = False
            Exit Function
        Else
            strFilePath = fldrs(0)
            For elem = 1 To UBound(fldrs)
                strFilePath = strFilePath & "\" & fldrs(elem)
                If Not fso.FolderExists(strFilePath) Then
                    If createFolders Then
                        fso.CreateFolder strFilePath
                    Else
                        md = False
                        Exit Function
                    End If
                End If
            Next
        End If
    End If
End Function

Select allOpen in new window