Добрый день! Вводные: есть таблица Excel с данными Компаний, которые проходили обучение (каждый год имеет отдельный Лист в таблице) и получили сертификат сроком на 2 года. Соответственно, по окончании действия сертификата (за один месяц) необходимо напомнить Компании, что срок действия сертификата истекает. В Excel таблице записаны следующие данные, даты прохождения обучения, название компаний, контактная информация (тел. , e-mail), ФИО. Данные в таблицу заносятся в ручную, после каждого обучения. В среднем в месяц 5...10 контактов *12 месяцев. Ведётся с 2018 года.
Задача: необходима автоматическая рассылка писем через Оutlook (тема, тело письма, подпись +файл с вложением). Рассылка должна производиться на основании данных (даты) из таблицы Excel, за один месяц до окончания даты срока действия сертификата.
Что есть: взял готовый макрос из интернета и допилил его - есть тема, само письмо, есть подпись и файл с вложением. НО нет автоматической рассылки, только в ручную, командой run.
Сильно не пинайте, это первый опыт в макросах .
Sub send_email() Dim olApp AsObject
Dim olMailItm AsObject Dim iCounter AsInteger Dim Dest AsVariant Dim SDest AsString ' e-mail subject
strSubj = "Окончание срока сертификата (название компании)" OnErrorGoTo dbg ' creating odject for Outlook Set olApp = CreateObject("Outlook.Application") For iCounter = 1To WorksheetFunction.CountA(Columns(1)) ' creating new element (email message) in Outlook Set olMailItm = olApp.CreateItem(0)
strBody = ""
useremail = Cells(iCounter, 1).Value
FullUsername = Cells(iCounter, 2).Value
Status = Cells(iCounter, 4).Value
pwdchange = Cells(iCounter, 3).Value ' body of the email
strBody = "Вас приветствует команда (название компании)!" & vbCrLf
strBody = strBody & " " & vbCrLf
strBody = strBody & "Приглашаем на сервисное обучение (тело письма) " & vbCrLf
strBody = strBody & " Дата окончания действия сертификата " & pwdchange & vbCrLf
strBody = strBody & " Надеемся на дальнейшее сотрудничество! " & vbCrLf
strBody = strBody & " " & vbCrLf
strBody = strBody & "---" & vbCrLf
strBody = strBody & ""
strBody = strBody & "Best regards," & vbCrLf
strBody = strBody & ""
strBody = strBody & " " & vbCrLf
strBody = strBody & ""
strBody = strBody & "Andrew " & vbCrLf
strBody = strBody & ""
strBody = strBody & "Tel.: +7" & vbCrLf
strBody = strBody & ""
strBody = strBody & "Tel: +7 (Moscow)" & vbCrLf
olMailItm.To = useremail
olMailItm.Subject = strSubj
olMailItm.BodyFormat = 1 ' 1 - text format of letter, 2 - HTML format
olMailItm.Body = strBody
olMailItm.Attachments.Add "C:\Users\Desktop\УНО\Cервисное обучение на I-квартал 2023 год.pdf"
olMailItm.Save
olMailItm.Send ' etu strochku mojno ispolzovat dlia otkladki pisma 'MsgBox strBody Set olMailItm = Nothing Next iCounter Set olApp = Nothing
dbg: 'errors,if yes If Err.Description <> ""Then MsgBox Err.Description EndSub
Добрый день! Вводные: есть таблица Excel с данными Компаний, которые проходили обучение (каждый год имеет отдельный Лист в таблице) и получили сертификат сроком на 2 года. Соответственно, по окончании действия сертификата (за один месяц) необходимо напомнить Компании, что срок действия сертификата истекает. В Excel таблице записаны следующие данные, даты прохождения обучения, название компаний, контактная информация (тел. , e-mail), ФИО. Данные в таблицу заносятся в ручную, после каждого обучения. В среднем в месяц 5...10 контактов *12 месяцев. Ведётся с 2018 года.
Задача: необходима автоматическая рассылка писем через Оutlook (тема, тело письма, подпись +файл с вложением). Рассылка должна производиться на основании данных (даты) из таблицы Excel, за один месяц до окончания даты срока действия сертификата.
Что есть: взял готовый макрос из интернета и допилил его - есть тема, само письмо, есть подпись и файл с вложением. НО нет автоматической рассылки, только в ручную, командой run.
Сильно не пинайте, это первый опыт в макросах .
Sub send_email() Dim olApp AsObject
Dim olMailItm AsObject Dim iCounter AsInteger Dim Dest AsVariant Dim SDest AsString ' e-mail subject
strSubj = "Окончание срока сертификата (название компании)" OnErrorGoTo dbg ' creating odject for Outlook Set olApp = CreateObject("Outlook.Application") For iCounter = 1To WorksheetFunction.CountA(Columns(1)) ' creating new element (email message) in Outlook Set olMailItm = olApp.CreateItem(0)
strBody = ""
useremail = Cells(iCounter, 1).Value
FullUsername = Cells(iCounter, 2).Value
Status = Cells(iCounter, 4).Value
pwdchange = Cells(iCounter, 3).Value ' body of the email
strBody = "Вас приветствует команда (название компании)!" & vbCrLf
strBody = strBody & " " & vbCrLf
strBody = strBody & "Приглашаем на сервисное обучение (тело письма) " & vbCrLf
strBody = strBody & " Дата окончания действия сертификата " & pwdchange & vbCrLf
strBody = strBody & " Надеемся на дальнейшее сотрудничество! " & vbCrLf
strBody = strBody & " " & vbCrLf
strBody = strBody & "---" & vbCrLf
strBody = strBody & ""
strBody = strBody & "Best regards," & vbCrLf
strBody = strBody & ""
strBody = strBody & " " & vbCrLf
strBody = strBody & ""
strBody = strBody & "Andrew " & vbCrLf
strBody = strBody & ""
strBody = strBody & "Tel.: +7" & vbCrLf
strBody = strBody & ""
strBody = strBody & "Tel: +7 (Moscow)" & vbCrLf
olMailItm.To = useremail
olMailItm.Subject = strSubj
olMailItm.BodyFormat = 1 ' 1 - text format of letter, 2 - HTML format
olMailItm.Body = strBody
olMailItm.Attachments.Add "C:\Users\Desktop\УНО\Cервисное обучение на I-квартал 2023 год.pdf"
olMailItm.Save
olMailItm.Send ' etu strochku mojno ispolzovat dlia otkladki pisma 'MsgBox strBody Set olMailItm = Nothing Next iCounter Set olApp = Nothing
dbg: 'errors,if yes If Err.Description <> ""Then MsgBox Err.Description EndSub