script to save outlook mail attachment

'with improvement to save files based on extention, and categorized by date
'gaixixon@gmail.com
Public Function checkDir(strFullPath As String) As Boolean
    If Len(Dir(strFullPath, vbDirectory)) = 0 Then
        checkDir = False
    Else
        checkDir = True
    End If
End Function



'with improvement to save files based on extention, and categorized by date
'gaixixon@gmail.com

Sub saveAttachtoDiskz(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim filetype As String


dateFormat = Format(Now, "YYYY-mm-dd") 'SAVE THE ATTACHMENTS IN FOLDERS BASED ON YEAR-MONTH-DATE RECEIVED'
saveFolder = "d:\tmp\Outlook Attachment" ' ROOT LOCATION WHERE ATTACHMENTS ARE SAVED'
filetype = ".pDf; .docx; .doc"    ' FILE TYPES THAT NEED TO BE SAVED, SEPERATED BY ;'


tmp = Split(saveFolder, "\")
saveFolder = tmp(0)
For i = LBound(tmp) + 1 To UBound(tmp)
saveFolder = saveFolder & "\" & tmp(i)
If Not checkDir(saveFolder) Then MkDir saveFolder
Next i


For Each objAtt In itm.Attachments
    If InStr(UCase(filetype), UCase(Split(objAtt.DisplayName, ".")(UBound(Split(objAtt.DisplayName, "."))))) > 0 Then
        If Not checkDir(saveFolder & "\" & dateFormat) Then MkDir (saveFolder & "\" & dateFormat)
        objAtt.SaveAsFile saveFolder & "\" & dateFormat & "\" & itm.SenderEmailAddress & " - " & objAtt.DisplayName
    End If

Set objAtt = Nothing

Next
End Sub