Δευτέρα, 29 Μάρτιος 2021
  0 Απαντήσεις
  2.8K Επισκέψεις
0
Ψηφοφορίες
Αναίρεση
Γεια, Χρησιμοποιώ τον κώδικά σας για να στείλω ένα εύρος του Excel ως συνημμένο email, αλλά λαμβάνω σφάλμα χρόνου εκτέλεσης εάν ακυρώσω το εύρος. Υπάρχει κωδικός που μπορώ να προσθέσω ή ένα msgbox για να μην συμβεί αυτό; Ευχαριστώ τον παρακάτω κωδικό.

Sub SendRange()
Dim xFile ως συμβολοσειρά
Dim xFormat As Long
Dim Wb ως βιβλίο εργασίας
Dim Wb2 ως βιβλίο εργασίας
Φύλλο εργασίας Dim Ws As
Dim FilePath ως συμβολοσειρά
Dim FileName As String
Εξασθένιση του OutlookApp ως αντικείμενο
Εξασθένιση του OutlookMail ως αντικείμενο
Dim WorkRng As Range
xTitleId = "Παράδειγμα"
Set WorkRng = Εφαρμογή.Επιλογή
Ορισμός WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ορισμός Wb = Application.ActiveWorkbook
Wb.Φύλλα εργασίας.Προσθήκη
Σετ Ws = Application.ActiveSheet
WorkRng.Copy Ws.Cells(1, 1)
Ws.Αντιγραφή
Ορισμός Wb2 = Application.ActiveWorkbook
Επιλέξτε Case Wb.FileFormat
Περίπτωση xlOpenXMLWorkbook:
    xFile = ".xlsx"
    xFormat = xlOpenXMLWorkbook
Περίπτωση xlOpenXMLWorkbookMacroEnabled:
    Αν Wb2.HasVBProject Τότε
        xFile = ".xlsm"
        xFormat = xlOpenXMLWorkbookMacroEnabled
    Αλλού
        xFile = ".xlsx"
        xFormat = xlOpenXMLWorkbook
    End If
Περίπτωση Excel8:
    xFile = ".xls"
    xFormat = Excel8
Περίπτωση xlExcel12:
    xFile = ".xlsb"
    xFormat = xlExcel12
Επιλέξτε Τερματισμός
FilePath = Environ$("temp") & "\"
FileName = Wb.Name & Format (Τώρα, "ηη-μμμ-εε ω-μμ-δδ")
Ορισμός OutlookApp = CreateObject ("Outlook.Application")
Ορισμός OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
Με το OutlookMail
    .Προς = ""
    .CC = ""
    .BCC = ""
    .Θέμα = "Δοκιμές"
    .Body = "Γεια σου."
    .Συνημμένα.Προσθήκη Wb2.FullName
    .Στείλετε
Τέλος με
Wb2.Κλείσιμο
Kill FilePath & FileName & xFile
Ορισμός OutlookMail = Τίποτα
Ορισμός OutlookApp = Τίποτα
Ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sub End
 
Δεν υπάρχουν ακόμη απαντήσεις για αυτήν την ανάρτηση.