MSSQL and VBA - automatic mail sender auto-created Excel file

Вариант отправки автоматической справки из MS SQL посредством VBA

'модуль формирования сводной таблицы по проекту
Option Compare Database 'сортировка символов определяется базой данных
Option Explicit 'запретить не объявленные переменные
Dim RS As New ADODB.Recordset 'объект набора данных
Dim EA As Excel.Application 'объект приложения Excel
Dim i As Integer, j, MyVal As Integer 'счетчики
Dim DA 'динамический массив для вывода данных
Const Шаблон As String = "\Шаблоны\Справка.xlt" 'относительный путь к шаблону
 Const emails As String = "grrg@mail.org; tgrta@mail.org; grtgtrv@mail.org; rgtn@mail.org"
 Dim e As Variant
 Dim FileAttachment As String
 Dim FileAttachmentTwo As String
 Dim Проект, Продукт, Имя, Представление As String

Sub ХодТПП()
   Проект = "КакойтоПроект"
   Продукт = "%"
   Представление = "SELECT Отчет.* " & _
   " FROM dbo.Отчет('" & Проект & "', '" & Продукт & "') Отчет"
    Set EA = CreateObject("Excel.Application") 'запускаем Excel
    EA.Workbooks.Add Template:=Application.CurrentProject.Path & Шаблон 'открываем шаблон
    EA.Goto "дата" 'переходим к метке подзаголовка
    EA.ActiveCell.Formula = EA.ActiveCell.Formula & " по состоянию на " & Date & " " & Time 'выводим текущую дату и время
    EA.Goto "таблица" 'переходим к метке таблицы
    'Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command
    With cmd
    .CommandTimeout = 60
    End With
    RS.Open Представление, CurrentProject.Connection, adOpenKeyset, adLockOptimistic, adCmdText
    'rs.Open Представление, cmd.ActiveConnection
    ReDim DA(0 To 0, 0 To RS.Fields.Count - 1) 'выделяем память для заголовка таблицы
    For j = 0 To RS.Fields.Count - 1 'перебираем все поля функции
        DA(0, j) = RS.Fields(j).Name 'заносим имена полей в массив
    Next j
    EA.Range(EA.ActiveCell.Offset(0, 0), EA.ActiveCell.Offset(0, RS.Fields.Count - 1)).Formula = DA 'выводим шапку таблицы
    Erase DA 'очищаем массив, освобождаем память
    RS.MoveLast 'переходим в конец для подсчёта количества строк в наборе данных
    ReDim DA(0 To RS.RecordCount - 1, 0 To RS.Fields.Count - 1) 'выделяем память для данных таблицы
    RS.MoveFirst 'возвращаемся в начало
    i = 0 'инициализируем счётчик строк
    Do While Not RS.EOF ' перебираем строки
        For j = 0 To RS.Fields.Count - 1 'перебираем поля
            DA(i, j) = RS(j) 'заносим данные в массив
        Next j
        RS.MoveNext 'читаем следующую строку набора данных
        i = i + 1 ' увеличить порядковый месяц
    Loop
    'выводим массив в таблицу
    EA.Range(EA.ActiveCell.Offset(1, 0), EA.ActiveCell.Offset(RS.RecordCount, RS.Fields.Count - 1)).Formula = DA
    RS.Close 'закрываем набор данных
    Set RS = Nothing 'освобождаем память
    EA.Goto "дата" 'переходим к метке подзаголовка
    'EA.ActiveCell.Formula = EA.ActiveCell.Formula & " по состоянию на " & Date & " " & Time 'выводим текущую дату и время
    Имя = Replace(Проект, "]", "")
    Имя = Replace(Проект, "[", "")
    Имя = Replace(Проект, "_", " ")
    Имя = Replace(Проект, "/", " ")
    Имя = Replace(Проект, "%", "")
    If Len(Имя) > 0 Then EA.ActiveCell.Offset(-1, 0).Formula = EA.ActiveCell.Offset(-1, 0).Formula & " по проекту " & Имя
    If Продукт <> "%" Then EA.ActiveCell.Offset(-1, 0).Formula = EA.ActiveCell.Offset(-1, 0).Formula & " по продукту " & Продукт
    'сохраняем документ
    EA.ActiveWorkbook.CheckCompatibility = False
    EA.DisplayAlerts = False
    EA.ActiveWorkbook.SaveAs Application.CurrentProject.Path & "\" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & "=Отчет_" & Имя & " " & Replace(Продукт, "%", ""), xlExcel8, , , , , , True
    EA.Visible = True 'делаем Excel видимым
    EA.DisplayAlerts = True
    EA.Application.Quit
    Set EA = Nothing 'очищаем переменную и отключаемся от Excel
    Set cmd = Nothing
    FileAttachmentTwo = Application.CurrentProject.Path & "\" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & "=справка_" & Имя & " " & Replace(Продукт, "%", "") & ".xls"
     
     
 
    e = SendEMail(emails, "Тема сообщения", "См. вложение" & Chr(13) & Chr(13) & "С уважением, " & Chr(13) & "Друг семьи  " & Chr(13) & "Тел.  такой то", FileAttachment & "," & FileAttachmentTwo)
End Sub

Public Function SendEMail(MailTo As String, Subjectline As String, MyBodyText As String, MyAttachment As String)
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim BodyFile As String
Dim SplitFiles
'Subjectline$ = "TEMA"
'MyBodyText = "It is auto-letter"
Set MyOutlook = New Outlook.Application
Set MyMail = MyOutlook.CreateItem(olMailItem)
MyMail.To = MailTo
MyMail.Subject = Subjectline$
MyMail.Body = MyBodyText
'MyMail.CC = "site@mail.org"
MyMail.BCC = "site@mail.org"
SplitFiles = Split(MyAttachment, ",")
If Len(MyAttachment) > 0 Then MyMail.Attachments.Add Trim(SplitFiles(0))
'If Len(MyAttachment) > 0 Then MyMail.Attachments.Add Trim(SplitFiles(1)) ' можно присоединить еще один сформированный файл
'MyMail.Attachments.Add "C:\somefile.xls"
'With MItem
'    .To = "test@email.com"
'    .Subject = "Commission check for future contracts"
'    .Body = Msg
'    .Attachments.Add "C:\My Documents\sample.xls"
'    .send
'End With
MyMail.send
Set MyMail = Nothing
Set MyOutlook = Nothing
End Function