Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
21.06.2021, 04:33:38

Войти
Название темы должно отражать её содержание.
Темы типа "ПОМОГИТЕ!!!", "Срочно!", "Не получается сделать", "Нужна помощь" и т.п. будут удаляться без объяснения причин
32 305 Сообщений в 5 230 Тем от 13 424 Пользователей
Последний пользователь: asgvba
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  Сохранить и отправить лист из книги в формате pdf на почту
Страниц: [1]   Вниз
Печать
Автор Тема: Сохранить и отправить лист из книги в формате pdf на почту  (Прочитано 273 раз)
0 Пользователей и 1 Гость смотрят эту тему.
Ибрагим
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля E-mail
« : 11.06.2021, 11:11:41 »

Я на этом сайте нашёл макрос, но у меня почтовая программа не Outlook, а Mozilla Thunderbird, как с ней настроить этот макрос?
Код: (vb)
Option Explicit
 
Sub Send_Mail()
    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
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "AddressTo@mail.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Привет от Excel-VBA"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
 
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +467/-0
Офлайн Офлайн

Сообщений: 5 520



Просмотр профиля WWW
« Ответ #1 : 11.06.2021, 11:48:12 »

как с ней настроить этот макрос?
Никак. И насколько я знаю у Mozilla Thunderbird нет своей библиотеки, к которой можно было бы получить доступ через CreateObject.
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Ибрагим
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля E-mail
« Ответ #2 : 11.06.2021, 13:34:50 »

А если через Outlook, то как сделать, чтобы этот макрос отравлял лист из файла Эксель в формате pdf?
Записан
Ибрагим
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля E-mail
« Ответ #3 : 11.06.2021, 13:37:31 »

Я на этом сайте нашёл макрос, как сделать так, чтобы он отправлял лист из файла Эксель в формате pdf?
Код: (vb)
Option Explicit
 
Sub Send_Mail()
    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
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "AddressTo@mail.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Привет от Excel-VBA"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
 
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +467/-0
Офлайн Офлайн

Сообщений: 5 520



Просмотр профиля WWW
« Ответ #4 : 11.06.2021, 14:55:01 »

Ибрагим, что в последнем сообщении Вы хотели донести? Зачем цитировать свое первое сообщение целиком, да еще без какого-либо смыслового наполнения?
По вопросу: запишите макрорекордером сохранения нужного листа в PDF и используйте в коде. Это вроде как не мега сложная задача:
Код: (vb)
sAttachment = "C:\Users\Дмитрий\Desktop\Книга1.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sAttachment, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False

останется этот код добавить перед строкой
Код: (vb)
sTo = "AddressTo@mail.ru"
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Ибрагим
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля E-mail
« Ответ #5 : 11.06.2021, 15:20:02 »

Извините, последнее сообщение по ошибке отправил.
Я сделал вроде как вы сказали, но в итоге макрос отправляет пустое сообщение без вложения
Код: (vb)
Sub Send_Mail()
    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
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY " & "г.").pdf
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sAttachment, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
    sTo = "IbrahimBelkhoroev6@gmail.com"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = ""    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = ""    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY " & "г.").pdf    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
   
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
   
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +467/-0
Офлайн Офлайн

Сообщений: 5 520



Просмотр профиля WWW
« Ответ #6 : 11.06.2021, 16:07:49 »

Вы сделали не так как я написал. Оставить надо только то, что я показал, а строку
Код: (vb)
sAttachment = "C:\Temp\Книга1.xls"    '

удалить вообще. Логику-то включайте. Ну и строка Ваша я не знаю на чем и как основана, но выглядит не соответствующей синтаксису хотя бы потому, что ").pdf" без кавычек. Учите хотя бы азы VBA, должно быть так:
Код: (vb)
sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf"
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Ибрагим
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля E-mail
« Ответ #7 : 12.06.2021, 13:45:28 »

Этот код работает, вот только мне нужно добавить свои предпочтения, а именно, чтобы вставленный рисунок не выводился при отправке на один адрес почты, а на другой выводился и ещё добавить в письмо подпись, она у меня стоит в самой почте по умолчанию?
Код: (vb)
Sub Send_Mail()
    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
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sAttachment, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
    sTo = "IbrahimBelkhoroev6@gmail.com"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf"   'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = ""    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        sAttachment, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False   'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
   
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        'добавляем подпись к письму
        'создаем новое письмо
        Set objTmpMail = objOutlookApp.CreateItem(0)
        'отображаем его - у него появится подпись
        objTmpMail.Display
        'теперь к нашему текущему(рабочему) письму просто добавляем текст из временного
        objMail.body = objMail.body & objTmpMail.body
        'удаляем временное письмо
        objTmpMail.Delete
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
   
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +467/-0
Офлайн Офлайн

Сообщений: 5 520



Просмотр профиля WWW
« Ответ #8 : 13.06.2021, 10:32:09 »

вот только мне нужно
ещё добавить
И с правилами форума ознакомиться, раз согласились с ними при регистрации.
Все Ваши остальные вопросы не имеют прямого отношения к созданной теме. Да и непонятно ни разу, на какой адрес надо, а на какой нет, если у Вас в принципе только один адрес используется в отправке. Да и про какой рисунок речь тоже неясно.

добавить в письмо подпись
Это все давно есть на сайте: Вставить в письмо подпись из Outlook через VBA
Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
Ибрагим
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 6


Просмотр профиля E-mail
« Ответ #9 : 14.06.2021, 10:55:04 »

Я добавил подпись, там оказывается нужно было сначала в Outlook добавить подпись, но сейчас снова столкнулся с проблемой, дело в том, что шрифт подписи не тот, что мне нужен хотя я добавил подпись в Outlook в нужном мне шрифте и картинка в этой подписи не отображается в письме после отправки, там просто название картинки бывает и все, не знаете, как это исправить, может там в коде нужно что-то добавить?
Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru