Отправить заархивированных файл

[vika_pravda]

Добрый день! Ранее уже вам писала, необходимо доработать макрос.
Задача следующая: необходимо архивированный файл отправить через outlook. Ранее я нашла макрос на архивирование файлов - всё работает, НО в макросе на отправку файла по почте необходимо указывать адрес файла и с этим проблема. Можно как-то написать макрос, чтобы уже заархивированный файл отправлялся?

Сейчас код следующий, выходит ошибка "Object variable or With block varible not set"

Код: (vb)

Sub CreateNewZip(sPath As String)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub
Sub Zip_File_Or_Files()
    Dim sDate As String, sZIPPath As String, sZIPFileName As String, sWBName As String
    Dim objShell As Object, lf As Long, lZIPCnt As Long
    Dim avFiles
    avFiles = Application.GetOpenFilename("TEXT Files (*.txt*),*.txt*", , "Выбрать файлы для архивации", , True)
    If VarType(avFiles) = vbBoolean Then Exit Sub
    sZIPPath = Replace(avFiles(1), Dir(avFiles(1), 16), "")
    If Right(sZIPPath, 1) <> "\" Then
        sZIPPath = sZIPPath & "\"
    End If
    
    sDate = Format(Now, " dd-mm-yy h-mm-ss")
    sZIPFileName = sZIPPath & "Логи" & sDate & ".zip"
    CreateNewZip (sZIPFileName)
    Set objShell = CreateObject("Shell.Application")
    lZIPCnt = 0
    For lf = LBound(avFiles) To UBound(avFiles)
        sWBName = Dir(avFiles(lf), 16)
        If IsBookOpen(sWBName) Then
            MsgBox "Невозможно поместить книгу '" & avFiles(lf) & "' в архив!" & vbNewLine & _
                   "Закройте книгу и повторите попытку."
        Else
            lZIPCnt = lZIPCnt + 1
            objShell.Namespace((sZIPFileName)).CopyHere CStr(avFiles(lf))
            Do Until objShell.Namespace((sZIPFileName)).Items.Count = lZIPCnt
                DoEvents
            Loop
        End If
    Next lf
    If lZIPCnt Then
        MsgBox "Архив создан по пути: " & sZIPFileName
    End If
    Send_Mail (sNewMail)
End Sub
Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook: On Error Resume Next
    Set wbBook = Workbooks(wbName)
    IsBookOpen = Not wbBook Is Nothing
End Function
Sub Send_Mail(sPath As String)
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    sTo = Range("A2" & "A3" & "A4" & "A5" & "A6" & "A7" & "A8" & "A9" & "A10" & "A11").Value
    sSubject = "Тест"
    sBody = "Добрый день! Высылаю вам выгрузку"
    With objMail
        .To = sTo
        .CC = ""
        .BCC = ""
        .Subject = sSubject
        .Body = sBody
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment
            End If
        End If
        .Send
        End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
    
    

[Дмитрий Щербаков(The_Prist)]

1. Что такое sNewMail? Где эта переменная и где ей назначается хоть какое-то значение? Если собирались передать туда путь к архиву - то у Вас для этого совсем другая переменная используется: sZIPFileName. В ней уже все есть - её и передавайте. И без скобок, кстати.
2. Вот передали Вы sZIPFileName(в Send_Mail это у Вас переменная sPath). А в коде отправки Вы что к письму прикладываете? Правильно - ничего. Т.к. sAttachment у Вас нигде никакого значения не получает. Добавьте перед

Код: (vb)

With objMail

такую строку:

Код: (vb)

sAttachment = sPath

[vika_pravda]

Я не очень поняла. Функцию:

Код: (vb)

 
ub Send_Mail(sPath As String)
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    sTo = Range("A2" & "A3" & "A4" & "A5" & "A6" & "A7" & "A8" & "A9" & "A10" & "A11").Value
    sSubject = "Тест"
    sBody = "Добрый день! Высылаю вам выгрузку"
    sAttachment = sPath
    With objMail
        .To = sTo
        .CC = ""
        .BCC = ""
        .Subject = sSubject
        .Body = sBody
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment
            End If
        End If
        .Send
        End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

* добавила, как вы сказали: sAttachment = sPath.

Про скобки хотела отдельно спросить, у вас в вашем примере указаны скобки

Мы оставляем или вписываем ее в

Код: (vb)

Sub CreateNewZip(sPath As String)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

[Дмитрий Щербаков(The_Prist)]

Эх...Все не так, как написал. Я же писал про sZIPFileName. Она у Вас используется в процедуре Zip_File_Or_Files. Причем здесь CreateNewZip? Очень, очень мало у Вас знаний для реализации подобных задач...Должно было быть вот так:

Код: (vb)

Sub CreateNewZip(sPath As String)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub
Sub Zip_File_Or_Files()
    Dim sDate As String, sZIPPath As String, sZIPFileName As String, sWBName As String
    Dim objShell As Object, lf As Long, lZIPCnt As Long
    Dim avFiles
    avFiles = Application.GetOpenFilename("TEXT Files (*.txt*),*.txt*", , "Выбрать файлы для архивации", , True)
    If VarType(avFiles) = vbBoolean Then Exit Sub
    sZIPPath = Replace(avFiles(1), Dir(avFiles(1), 16), "")
    If Right(sZIPPath, 1) <> "\" Then
        sZIPPath = sZIPPath & "\"
    End If
      
    sDate = Format(Now, " dd-mm-yy h-mm-ss")
    sZIPFileName = sZIPPath & "Логи" & sDate & ".zip"
    CreateNewZip (sZIPFileName)
    Set objShell = CreateObject("Shell.Application")
    lZIPCnt = 0
    For lf = LBound(avFiles) To UBound(avFiles)
        sWBName = Dir(avFiles(lf), 16)
        If IsBookOpen(sWBName) Then
            MsgBox "Невозможно поместить книгу '" & avFiles(lf) & "' в архив!" & vbNewLine & _
                   "Закройте книгу и повторите попытку."
        Else
            lZIPCnt = lZIPCnt + 1
            objShell.Namespace((sZIPFileName)).CopyHere CStr(avFiles(lf))
            Do Until objShell.Namespace((sZIPFileName)).Items.Count = lZIPCnt
                DoEvents
            Loop
        End If
    Next lf
    If lZIPCnt Then
        MsgBox "Архив создан по пути: " & sZIPFileName
    End If
    Send_Mail sZIPFileName
End Sub
Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook: On Error Resume Next
    Set wbBook = Workbooks(wbName)
    IsBookOpen = Not wbBook Is Nothing
End Function
Sub Send_Mail(sPath As String)
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
   
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    sTo = Range("A2" & "A3" & "A4" & "A5" & "A6" & "A7" & "A8" & "A9" & "A10" & "A11").Value
    sSubject = "Тест"
    sBody = "Добрый день! Высылаю вам выгрузку"
    sAttachment = sPath
    With objMail
        .To = sTo
        .CC = ""
        .BCC = ""
        .Subject = sSubject
        .Body = sBody
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment
            End If
        End If
        .Send
        End With
   
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

[vika_pravda]

Не цитируйте сообщения полностью - достаточно выделить нужную фразу и нажать ЦИТИРОВАТЬ. п.п. 4.18 Правил форума

Добрый день! К сожалению, файлы архивируются, но не отправляются по почте.
Почту в ячейку я внесла, ошибки никакой не выходит.

Работает, если в код внести саму почту, а если указать почту в ячейку, то нет

[Дмитрий Щербаков(The_Prist)]

Не сразу заметил:

Код: (vb)

sTo = Range("A2" & "A3" & "A4" & "A5" & "A6" & "A7" & "A8" & "A9" & "A10" & "A11").Value 

Код рассчитан на отправку email только на один адрес, указанный как раз в этой ячейке. Что Вы хотели сказать VBA этой строкой? Вы явно совершенно не знакомы с синтаксисом VBA - мало того, что такая запись избыточна, она еще и неправильная в части обращения к ячейке. В итоге у Вас получается ссылка на ячейку:

Код: (vb)

sTo = Range("A2A3A4A5A6A7A8A9A10A11").Value

а такой ячейки нет и быть не может. А т.к. в начале кода стоит игнорирование ошибок:

Код: (vb)

On Error Resume Next

то никакая ошибка и не появляется.

P.S. Не цитируйте сообщения полностью - достаточно выделить нужную фразу и нажать ЦИТИРОВАТЬ. п.п. 4.18 Правил форума

[vika_pravda]

Хорошо, а мы можем данный код объединить с кодом, например, массовой рассылки? https://www.excel-vba.ru/chto-umeet-excel/kak-otpravit-pismo-iz-excel/comment-page-8/#comments
Единственное, у вас тут в колонке D есть адреса файлов

[vika_pravda]

Дмитрий, я решила проблему, разобралась спасибо!

[vika_pravda]

Дмитрий, добрый день!
Показала макрос, есть несколько дополнений по нему, можете помочь: может на вашем сайте уже были похожие кейсы?

1. Адрес папки необходимо сделать автоматизированным. У каждого сотрудника есть своя папка, откуда необходимо брать данные. Имена у всех папок стандартизированы, кроме именного домена, который совпадает с именем пользователя. Можем мы как-то в макросе это указать?
2. Внутри личной папки будет три папки, среди которых пользователь должен выбрать из какой папки данные брать. Условно, сейчас это форма в excel, сотрудник с помощью выбора данных определяет необходимую папку. Название этой папки также идет в адрес папки.

Например, Иванов В.А. заходит в excel, выбирает папку, из которой он хочет взять данные, а в макросе автоматически в адрес папки поставляется пользователь учетной записи и название папки.

3. Макрос должен выбирать автоматически только последние файлы / файлы в названиях которых стоит максимальное число.

Например, Выручка_3 (то есть выручка за 3 неделю).

4. В некоторых случаях необходимо прикладывать скриншот к письму. Они всегда будут разные, поэтому мне кажется логичнее, чтобы макрос архивировал доки, открывал outlook, но не отправлял письмо, а сохранял в черновиках, чтобы пользователь мог отредактировать письмо.

Можно дать выбор сотрудники: с скриншотов => сохраняет в черновик; без скриншота => отправить сразу.

Заранее спасибо, если похожие примеры есть.