Tento kód uloží list jako nový sešit a vytvoří e -mail v aplikaci Outlook s připojeným novým sešitem. Je to velmi užitečné, pokud máte standardizovanou tabulku šablon, která se používá ve vaší organizaci.
Pro jednodušší příklad se podívejte na Jak posílat e -maily z Excelu
Uložte list jako nový sešit a přiložte k e -mailu
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = FalseApplication.enableevents = FalseApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualDim OutApp jako objektDim OutMail jako objektDim FilePath jako řetězecDim Project_Name jako řetězecDim Template_Name as StringDim ReviewDate jako řetězecDim SaveLocation As StringDim Path As StringDim Jméno jako řetězec`` Vytvořte počáteční proměnnéSet OutApp = CreateObject ("Outlook.Application")Set OutMail = OutApp.CreateItem (0)Project_Name = Listy ("sheet1"). Rozsah ("ProjectName"). HodnotaTemplate_Name = ActiveSheet.Name'Požádejte o zadání použité v e -mailuReviewDate = InputBox (Výzva: = "Zadejte datum do kdy chcete, aby byl příspěvek zkontrolován.", Název: = "Zadejte datum", výchozí: = "MM/DD/RRRR")If ReviewDate = "Zadejte datum" Nebo ReviewDate = vbNullString Then GoTo endmacro„Uložit list jako vlastní sešitCesta = ActiveWorkbook.PathNázev = Oříznout (střední (ActiveSheet.Name, 4, 99))Nastavit ws = ActiveSheetNastavit oldWB = ThisWorkbookSaveLocation = InputBox (Prompt: = "Choose File Name and Location", Title: = "Save As", Default: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")If Dir (SaveLocation) "" ThenMsgBox („Soubor s tímto názvem již existuje. Vyberte prosím nový název nebo odstraňte stávající soubor.“)SaveLocation = InputBox (Prompt: = "Choose File Name and Location", Title: = "Save As", Default: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Konec IfIf SaveLocation = vbNullString Then GoTo endmacro'v případě potřeby nechráněný listActiveSheet.Unprotect Heslo: = "heslo"Nastavit newWB = Workbooks.Add'Upravte zobrazeníActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Kopírovat + Vložit hodnotyoldWB. AktivovatoldWB.ActiveSheet.Cells.SelectVýběr. KopírovatnewWB.ActivatenewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, operace: = xlNone, SkipBlanks _: = False, Transpose: = FalseSelection.PasteSpecial Paste: = xlPasteFormats, operace: = xlNone, _SkipBlanks: = False, Transpose: = FalseSelection.PasteSpecial Paste: = xlPasteValidation, operace: = xlNone, _SkipBlanks: = False, Transpose: = False'Vyberte nový WB a vypněte režim cutcopynewWB.ActiveSheet.Range ("A10"). VyberteApplication.CutCopyMode = False'Uložení souborunewWB.SaveAs Název souboru: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = FalseFilePath = Application.ActiveWorkbook.FullName„Opravit starou WBoldWB.ActiveSheet.Protect Heslo: = "heslo", DrawingObjects: = pravda, obsah: = pravda, scénáře: = pravda _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'E-mailemPři chybě Pokračovat DalšíS OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Název_projektu & ":" & Název_šablony & "ke kontrole".Body = "Název projektu:" & Název_projektu & "," & Název & "Pro kontrolu" & ReviewDate.Attachments.Add (FilePath).Zobrazit'. Odeslat' Volitelné pro automatizaci odesílání e -mailů.Konec sPři chybě GoTo 0Set OutMail = NicSet OutApp = Nic'Ukončete makro, obnovte screenupdating, Calcs atd … endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticEnd Sub |
