Public Sub SaveAttachments(msg As MailItem)
    Dim att As Attachment
    Dim base_path As String
        base_path = "C:\temp\OutlookAttach\"
    Dim file_ext As String
        file_ext = "docx_xlsx_xls_doc_txt_img_pdf_ppt_pptx_mpp_zip_7z_rar_"
    Dim path_att As String
    Dim v_dateFormat
    v_dateFormat = Format(Now, " yyyy-mm-dd HH-mm-ss")
    Dim v_year
    v_year = Format(msg.ReceivedTime, "yyyy")
    Dim v_month
    v_month = Format(msg.ReceivedTime, "mm")

    For Each att In msg.Attachments
        v_dateFormat = Format(Now, " yyyy-mm-dd HH-mm-ss")
        Dim s As String
        s = att.FileName
        Dim pd As Integer
        pd = InStrRev(s, ".")
        Dim n As String, w As String
        n = Left(s, pd - 1)
        w = Right(s, Len(s) - pd)
        If InStr(1, file_ext, w) > 0 Then
            path_att = base_path & v_year
            If Not Dir(path_att, vbDirectory) <> "" Then
                MkDir (path_att)
            End If

            path_att = path_att & "\" & v_month
            If Not Dir(path_att, vbDirectory) <> "" Then
                MkDir (path_att)
            End If

            path_att = path_att & "\" & msg.SenderName
            If Not Dir(path_att, vbDirectory) <> "" Then
                MkDir (path_att)
            End If
        
            Do
                v_dateFormat = Format(Now, " yyyy-mm-dd HH-mm-ss")
            Loop Until Not Dir(path_att & "\" & n & v_dateFormat & "." & w) <> ""
           
            att.SaveAsFile path_att & "\" & n & v_dateFormat & "." & w
        End If
    Next
End Sub