Πίνακας περιεχομένων
Αυτός ο κώδικας αποθηκεύει ένα φύλλο εργασίας ως νέο βιβλίο εργασίας και δημιουργεί ένα μήνυμα ηλεκτρονικού ταχυδρομείου στο Outlook με το νέο βιβλίο εργασίας που επισυνάπτεται. Είναι πολύ χρήσιμο εάν έχετε ένα τυποποιημένο υπολογιστικό φύλλο προτύπων που χρησιμοποιείται σε ολόκληρο τον οργανισμό σας.
Για πιο απλό παράδειγμα, δείτε πώς να στείλετε email από το Excel
Αποθηκεύστε το φύλλο εργασίας ως νέο βιβλίο εργασίας και επισυνάψτε στο email
| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108 | Sub Mail_Workbook ()Application.DisplayAlerts = ΛάθοςApplication.enableevents = ΛάθοςApplication.ScreenUpdating = ΛάθοςApplication.Calculation = xlCalculationManualDim OutApp ως αντικείμενοDim OutMail ως αντικείμενοDim FilePath As StringDim Project_Name As StringDim Template_Name As StringDim ReviewDate As StringDim SaveLocation As StringDim Path As StringDim Name As String«Δημιουργία αρχικών μεταβλητώνSet OutApp = CreateObject ("Outlook.Application")Ορισμός OutMail = OutApp.CreateItem (0)Project_Name = Φύλλα ("φύλλο1"). Εύρος ("Όνομα έργου"). ΤιμήTemplate_Name = ActiveSheet.Name«Ζητήστε εισαγωγή που χρησιμοποιείται στο emailReviewDate = InputBox (Προτροπή: = "Παροχή ημερομηνίας έως ότου θέλετε να εξεταστεί η υποβολή.", Τίτλος: = "Εισαγωγή ημερομηνίας", Προεπιλογή: = "ΜΜ/ΗΗ/ΕΕΕΕ")Αν ReviewDate = "Εισαγωγή ημερομηνίας" Review ReviewDate = vbNullString Τότε GoTo endmacro«Αποθήκευση φύλλου εργασίας ως δικό σας βιβλίο εργασίαςPath = ActiveWorkbook.PathΌνομα = Trim (Mid (ActiveSheet.Name, 4, 99))Ορισμός ws = ActiveSheetΡύθμιση oldWB = ThisWorkbookSaveLocation = InputBox (Προτροπή: = "Επιλογή ονόματος και τοποθεσίας αρχείου", Τίτλος: = "Αποθήκευση ως", Προεπιλογή: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")If Dir (SaveLocation) "" ΤότεMsgBox ("Ένα αρχείο με αυτό το όνομα υπάρχει ήδη. Επιλέξτε ένα νέο όνομα ή διαγράψτε το υπάρχον αρχείο.")SaveLocation = InputBox (Προτροπή: = "Επιλογή ονόματος και τοποθεσίας αρχείου", Τίτλος: = "Αποθήκευση ως", Προεπιλογή: = CreateObject ("WScript.Shell"). SpecialFolders ("Desktop") & "/" & Name & ". xlsx ")Τέλος εανΑν SaveLocation = vbNullString Στη συνέχεια GoTo endmacro«απροστάτευτο φύλλο αν χρειαστείActiveSheet.Unprotect Password: = "password"Ορισμός newWB = Τετράδια εργασίας. Προσθήκη«Προσαρμογή οθόνηςActiveWindow.Zoom = 80ActiveWindow.DisplayGridlines = Λάθος'Αντιγραφή + Επικόλληση τιμώνoldWB. ΕνεργοποιήστεoldWB.ActiveSheet.Cells.SelectΕπιλογή. ΑντιγραφήnewWB. ΕνεργοποίησηnewWB.ActiveSheet.Cells.SelectSelection.PasteSpecial Paste: = xlPasteValues, Λειτουργία: = xlNone, SkipBlanks _: = Λάθος, Μεταφορά: = ΛάθοςSelection.PasteSpecial Paste: = xlPasteFormats, Λειτουργία: = xlΚανένα, _SkipBlanks: = Λάθος, Μεταφορά: = ΛάθοςSelection.PasteSpecial Paste: = xlPasteValidation, Λειτουργία: = xlΚανένα, _SkipBlanks: = Λάθος, Μεταφορά: = Λάθος'Επιλέξτε νέο WB και απενεργοποιήστε τη λειτουργία κοπήςnewWB.ActiveSheet.Range ("A10"). ΕπιλέξτεApplication.CutCopyMode = Λάθος'Αποθηκεύσετε το αρχείοnewWB.SaveAs Όνομα αρχείου: = SaveLocation, _FileFormat: = xlOpenXMLWorkbook, CreateBackup: = ΛάθοςFilePath = Application.ActiveWorkbook.FullName«Προστατέψτε το oldWBoldWB.ActiveSheet.Protect Password: = "password", DrawingObjects: = True, Περιεχόμενα: = True, Σενάρια: = True _, AllowFormattingCells: = True, AllowFormattingColumns: = True, _AllowFormattingRows: = True'ΗΛΕΚΤΡΟΝΙΚΗ ΔΙΕΥΘΥΝΣΗΣτο Σφάλμα Συνέχιση ΕπόμενοΜε OutMail.to = "[email protected]".CC = "".BCC = "".Subject = Project_Name & ":" & Template_Name & "for review".Body = "Όνομα έργου:" & Project_Name & "," & Name & "Για έλεγχο από" & ReviewDate. Συνημμένα. Προσθήκη (FilePath).Απεικόνιση'.Αποστολή' Προαιρετικό για αυτοματοποίηση αποστολής email.Τέλος μεΣφάλμα GoTo 0Set OutMail = ΤίποταSet OutApp = Τίποτα«Τερματισμός μακροεντολής, επαναφορά ενημέρωσης οθόνης, υπολογισμοί κλπ… endmacro:Application.DisplayAlerts = TrueApplication.enableevents = TrueApplication.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticΤέλος υπο |
