Страницы: 1
RSS
Отправка файлов по электронной почте находящихся в одном файле
 
Подскажите пожалуйста, а можно ли в этом макросе прописать, чтобы он отправлял ни один файл а все файлы разом находящиеся в одной папке. Макрос взял отсюда
Код
Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
     
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon      
    On Error GoTo cleanup  'если не запустился - выходим 
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").Value
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        .Attachments.Add Range("A4").Value
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой 
        .Send
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
 
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub
 
Можно, для этого нужно перебрать все файлы в папке. Здесь можно посмотреть как это сделать.  
 
Не совсем понял как, это сделать?
 
А что именно не понятно, по ссылке из сообщения создайте массив полных имен файлов, которые хотите отправить, а затем вашим кодом в цикле по массиву отправляйте файлы.
"Все гениальное просто, а все простое гениально!!!"
 
Вот сделал как Вы и сказали, outlook выполняет отправку но, ни чего не приходит. У меня в папке два файла, outlook дважды запускается, получается он пытается отправить два письма, и если в папке будет 10 файлов, столько же раз отправит. А одним разом как то можно сделать?
Код
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open sFolder & sFiles
        'действия с файлом
Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
      
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon      
    On Error GoTo cleanup  'если не запустился - выходим 
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").Value
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        .Attachments.Add Range("A4").Value
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой 
        .Send
    End With
  
    On Error GoTo 0
    Set OutMail = Nothing
  
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub
Изменено: Lerik2020 - 05.03.2020 23:31:15
 
Ну все же надо не прям полные куски вставлять, даже не вчитываясь в процесс :)
Код
Sub Get_All_File_from_Folder()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")   'запускаем Outlook в скрытом режиме
    OutApp.Session.Logon
    On Error GoTo cleanup  'если не запустился - выходим
    Set OutMail = OutApp.CreateItem(0)   'создаем новое сообщение
    On Error Resume Next
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'заполняем поля сообщения
    With OutMail
        .To = Range("A1").Value
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        sFiles = Dir(sFolder & "*.xls*")
        Do While sFiles <> ""
            'добавляем файл из папки как вложение
            .Attachments.Add sFolder & sFiles
            sFiles = Dir
        Loop
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой
        .Display '.Send
        
    End With
    On Error GoTo 0
    Set OutMail = Nothing
   
cleanup:
    Set OutApp = Nothing
     Application.ScreenUpdating = True
End Sub
раз статью явно не читали, то обращаю внимание на строку:
Код
sFiles = Dir(sFolder & "*.xls*")
она отбирает только файлы Excel. Если нужны все, то строка должна выглядеть так:
Код
sFiles = Dir(sFolder & "*.*")
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Макрос запускает outlook с прикрепленными файлами, я нажимаю отправить, outlook закрывается, но ни чего не приходит. Приходится вручную запускать outlook, и только после этого письмо приходит
 
Цитата
Lerik2020 написал:
только после этого письмо приходит
да, есть такой эффект. На форуме как-то обсуждалось уже. Вот тема с решениями по этому вопросу: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=124703
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Страницы: 1
Наверх