How do I save incoming email attachment to a specific folder

Sub saveXLAttachments(mai As MailItem)
Dim dosFolderPath As String
Dim tmpFolderPath As String
Dim intIncrement As Integer
Dim intAtt As Integer
Dim att As Attachment
Dim fn As String
Dim ft As String
Dim fso As Object
 
    dosFolderPath = "C:\Deleteme"
    If Right(dosFolderPath, 1) <> "\" Then dosFolderPath = dosFolderPath & "\"
    Set fso = CreateObject("scripting.filesystemobject")
    For intAtt = mai.Attachments.Count To 1 Step -1
        Set att = mai.Attachments(intAtt)
        intIncrement = 1
        fn = Left(att.FileName, InStrRev(att.FileName, ".") - 1)
        ft = Right(att.FileName, Len(att.FileName) - InStrRev(att.FileName, ".") + 1)
        If LCase(ft) = ".xls" Then
            If Len(fn) > 6 Then
                If IsNumeric(Right(fn, 6)) Then
                    If CInt(Right(fn, 2)) > 0 And CInt(Right(fn, 2)) <= 12 Then
                        tmpFolderPath = dosFolderPath & MonthName(CInt(Right(fn, 2))) & " " & Left(Right(fn, 6), 4) & "\"
                        md tmpFolderPath, True
                        Do While fso.FileExists(tmpFolderPath & fn & "_" & intIncrement & ft)
                            intIncrement = intIncrement + 1
                        Loop
                        att.SaveAsFile tmpFolderPath & fn & "_" & intIncrement & ft
                    End If
                End If
            End If
        End If
    Next
 
Set fso = Nothing
End Sub
 
 
 
 
 
Function md(dosPath As String, Optional createFolders As Boolean) As String
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
Dim bolret As Boolean
    
    md = ""
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        fldrs = Split(dosPath, "\")
        rootdir = fldrs(0)
        If Not fso.FolderExists(rootdir) Then
            Exit Function
        End If
 
        bolret = True
        For fldrIndex = 1 To UBound(fldrs) - 1
            rootdir = rootdir & "\" & fldrs(fldrIndex)
            If Not fso.FolderExists(rootdir) Then
                If createFolders Then
                    fso.CreateFolder rootdir
                Else
                    bolret = False
                End If
            End If
        Next
        If bolret Then
            For Each fldr In fso.getfolder(rootdir).SubFolders
                If Left(fldr.Name, 2) = fldrs(UBound(fldrs)) Then
                    md = fldr.Path
                    Exit Function
                End If
            Next
        End If
        Exit Function
    End If
End Function
 
If IsNumeric(Mid$(att.FileName, GetFirstNumberPosition(att.FileName), 6)) Then
 
Public Function GetFirstNumberPosition(ByVal sString As String) As Long
'------------------------------------------------------------------------------
'Cycles through a string from beginning to end, returns the characters
'from that string until it reaches a number. Return zero if not found or
'empty string
'
'Example:   GetFirstNumberPosition("HIF12125") returns 4
'Caveats:
'------------------------------------------------------------------------------
Dim sTemp As String
Dim l As Long
'''''''''''''''''''''''''''''''''''''''
GetFirstNumberPosition = 0
sTemp = sString
For l = 1 To Len(sTemp)
    Select Case Asc(Mid$(sTemp, l, 1))
    Case 48 To 57
        GetFirstNumberPosition = l
        Exit Function
    End Select
Next l
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104: