Option Compare Text
Sub SaveAllAttachments(objitem As MailItem)
    
    Dim objAttachments As Outlook.Attachments
    Dim strName, strLocation As String
    Dim dblCount, dblLoop As Double

    strLocation = "C:\Attachment\" 'папка куда будут сохраняться вложения, создаем руками

    
    On Error GoTo ExitSub
     If Len(Dir(strLocation & Date, vbDirectory)) = 0 Then 'проверка существования директории
        MkDir strLocation & Date 'делаем папку с текущей датой
        End If
     If objitem.Class = olMail Then
        Set objAttachments = objitem.Attachments
        dblCount = objAttachments.Count
        If dblCount <= 0 Then
          GoTo 100
        End If
        For dblLoop = 1 To dblCount
                strName = objAttachments.Item(dblLoop).FileName
                strName = strLocation & "\" & Date & "\" & strName
                objAttachments.Item(dblLoop).SaveAsFile strName
         Next dblLoop
    End If
100
    Call unrar 'разархивируем
    Call send 'отправляем
ExitSub:
    Set objAttachments = Nothing
    Set objOutlook = Nothing
End Sub

Sub unrar()
    ipath = "C:\Attachment\" & "\" & Date & "\"
    myname = Dir(ipath, vbNormal)
Do While myname <> ""
If myname Like "*.rar" Or myname Like "*.zip" Or myname Like "*.7z" Then
    WinRarApp$ = "C:\Program Files\WinRAR\WinRAR.exe x -o+ -y -vp"
    ' x - извлечь с полными путями
    ' -o+ - перезаписываем существующие файлы
    ' -y отвечаем на все запросы ДА
    ' -vp делает паузу перед следующим томом - не уверен в необходимости
    iArhivName$ = myname
    adr$ = WinRarApp$ & " """ & ipath & iArhivName$ & """ """ & ipath & """ "
    RetVal = Shell(adr$, vbHide)
End If
    myname = Dir()
Loop
End Sub

Sub send()
    Dim objOL As Outlook.Application
    Dim objMail As MailItem
    Dim fso, ts, s
    Const ForReading = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set objOL = Outlook.Application
    Set objMail = objOL.CreateItem(olMailItem)
    Set ts = fso.OpenTextFile("c:\testreadfile.txt", ForReading)
        s = ts.ReadAll
        With objMail
            .To = "" 'получатель
            '.CC = "" копия
            .Body = s             'тело письма
            .Subject = "Тема письма"             'тема
            '.Attachments.Add = ""   указывается полный путь к файлу
            .send
        End With
    ts.Close
    Set objMail = Nothing
    Set objOL = Nothing
End Sub

Sub getfile()
    ' ищем все файлы TXT
    ' Просматриваются папки с глубиной вложениея не более трех.

    Dim coll As Collection, PathTo As String
    ' получаем путь к папке
    PathTo = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    ' считываем в коллекцию coll нужные имена файлов
    Set coll = FilenamesCollection(PathTo, ".txt", 3)

    Application.ScreenUpdating = False    ' отключаем обновление экрана

End Sub