Deze code slaat een werkblad op als een nieuwe werkmap en maakt een e-mail in Outlook met de nieuwe werkmap als bijlage. Het is erg handig als u een gestandaardiseerde sjabloonspreadsheet heeft die in uw hele organisatie wordt gebruikt.
Kijk voor een eenvoudiger voorbeeld bij E-mail verzenden vanuit Excel
Werkblad opslaan als nieuwe werkmap en als bijlage toevoegen aan e-mail
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook()Application.DisplayAlerts = FalseApplication.enableevents = FalseApplication.ScreenUpdating = FalseToepassing.Berekening = xlBerekeningHandmatigDim Out-app als objectDim OutMail als objectDim FilePath als stringDim Project_Name As StringDim Template_Name als stringDim ReviewDate als stringDim SaveLocation As StringDim pad als stringNaam dimmen als string'Initiële variabelen maken'Stel OutApp = CreateObject ("Outlook.Application") inSet OutMail = OutApp.CreateItem (0)Project_Name = Sheets("sheet1").Bereik("ProjectName").WaardeTemplate_Name = ActiveSheet.Name'Vraag om invoer die wordt gebruikt in e-mail'ReviewDate = InputBox(Prompt:="Geef de datum op wanneer u de inzending wilt laten beoordelen.", Title:="Enter Date", Default:="MM/DD/YYYY")Als ReviewDate = "Voer datum in" of ReviewDate = vbNullString Dan ga naar endmacro'Werkblad opslaan als eigen werkboek'Pad = ActiveWorkbook.PadNaam = Trim(Mid(ActieveSheet.Naam, 4, 99))Stel ws = ActiveSheet inStel oldWB = ThisWorkbook inSaveLocation = InputBox(Prompt:="Kies bestandsnaam en locatie", Title:="Opslaan als", Standaard:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Naam & ". xlsx")If Dir(SaveLocation) "" DanMsgBox ("Er bestaat al een bestand met die naam. Kies een nieuwe naam of verwijder het bestaande bestand.")SaveLocation = InputBox(Prompt:="Kies bestandsnaam en locatie", Title:="Opslaan als", Standaard:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & "/" & Naam & ". xlsx")Stop alsAls SaveLocation = vbNullString Ga dan naar endmacro'unprotect blad indien nodig'ActiveSheet.Unprotect Password:="wachtwoord"Set newWB = Werkmappen.Toevoegen'Weergave aanpassen'ActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = False'Kopieer + plak waarden'oldWB.ActiverenoldWB.ActiveSheet.Cells.SelectSelectie.KopiërennieuweWB.ActiverennewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=Onwaar, transponeren:=OnwaarSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, transponeren:=FalseSelection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _SkipBlanks:=False, transponeren:=False'Selecteer nieuwe WB en schakel de modus voor kopiëren uit'newWB.ActiveSheet.Range("A10").SelecteerApplication.CutCopyMode = False'Sla bestand opnewWB.SaveAs Bestandsnaam:=SaveLocation, _FileFormat:=xlOpenXMLWorkbook, CreateBackup:=FalseFilePath = Application.ActiveWorkbook.FullName'OudeWB opnieuw beschermen'oldWB.ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenario's:=True _, AllowFormattingCells:=True, AllowFormattingColumns:=True, _AllowFormattingRows:=True'E-mail'Bij fout Hervatten volgendeMet OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ": " & Template_Name & " voor beoordeling".Body = "Projectnaam: " & Projectnaam & ", " & Naam & " Ter beoordeling door " & ReviewDate.Bijlagen.Toevoegen (FilePath).Weergave' .Send 'Optioneel om het verzenden van e-mail te automatiseren.Eindigt metBij fout Ga naar 0Set OutMail = NietsSet OutApp = Niets'Macro beëindigen, Screenupdating herstellen, Calcs, enz… endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueToepassing.Berekening = xlBerekeningAutomatischEinde sub |
