Этот код сохраняет рабочий лист как новую книгу и создает электронное письмо в Outlook с прикрепленной новой книгой. Это очень полезно, если у вас есть стандартизированная таблица с шаблоном, которая используется в вашей организации.
Более простой пример см. В статье Как отправить электронную почту из Excel.
Сохранить лист как новую книгу и прикрепить к электронной почте
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalseApplication.enableevents = ЛожьApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualDim OutApp как объектЗаменить исходящую почту как объектDim FilePath как строкаDim Project_Name As StringDim Template_Name As StringDim ReviewDate As StringУменьшить размер SaveLocation As StringТусклый путь как строкаТусклое имя как строка'Создать начальные переменныеУстановите OutApp = CreateObject ("Outlook.Application")Установите OutMail = OutApp.CreateItem (0)Project_Name = Sheets ("sheet1"). Диапазон ("ProjectName"). ЗначениеTemplate_Name = ActiveSheet.Name'Запрос ввода, используемый в электронной почтеReviewDate = InputBox (Prompt: = "Укажите дату, когда вы хотите, чтобы отправка была рассмотрена.", Title: = "Enter Date", по умолчанию: = "MM / DD / YYYY")Если ReviewDate = "Enter Date" или ReviewDate = vbNullString, тогда GoTo endmacro'Сохранить лист как собственную книгуПуть = ActiveWorkbook.PathИмя = Обрезать (Mid (ActiveSheet.Name, 4, 99))Установить ws = ActiveSheetУстановите oldWB = ThisWorkbookSaveLocation = InputBox (Prompt: = "Выберите имя и расположение файла", Title: = "Сохранить как", по умолчанию: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Если Dir (SaveLocation) "" ТогдаMsgBox («Файл с таким именем уже существует. Выберите новое имя или удалите существующий файл.»)SaveLocation = InputBox (Prompt: = "Выберите имя и расположение файла", Title: = "Сохранить как", по умолчанию: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Конец, еслиЕсли SaveLocation = vbNullString, то GoTo endmacro'снимите защиту с листа, если необходимоActiveSheet.Unprotect Пароль: = "пароль"Установите newWB = Workbooks.Add.'Настроить дисплейActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Копировать + вставить значенияoldWB.ActivateoldWB.ActiveSheet.Cells.SelectSelection.CopynewWB.ActivatenewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Operation: = xlNone, SkipBlanks _: = Ложь, Транспонировать: = ЛожьSelection.PasteSpecial Paste: = xlPasteFormats, Operation: = xlNone, _SkipBlanks: = False, Transpose: = FalseSelection.PasteSpecial Paste: = xlPasteValidation, Operation: = xlNone, _SkipBlanks: = False, Transpose: = False'Выберите новый WB и отключите режим копированияnewWB.ActiveSheet.Range ("A10"). ВыберитеApplication.CutCopyMode = False'Сохранить файлnewWB.SaveAs Имя файла: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalseFilePath = Application.ActiveWorkbook.FullName'Повторная защита oldWBoldWB.ActiveSheet.Protect Пароль: = "пароль", DrawingObjects: = True, Содержание: = True, Сценарии: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'Эл. адресПри ошибке Возобновить ДалееС OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "для проверки".Body = "Название проекта:" & Project_Name & "," & Name & "Для проверки до" & ReviewDate.Attachments.Add (путь к файлу).Отображать'.Send' Необязательно для автоматизации отправки электронной почты.Конец сПри ошибке GoTo 0Установить OutMail = NothingSet OutApp = Ничего'Завершить макрос, восстановить обновление экрана, вычислить и т. Д. Endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticКонец подписки |
