[VBA] Αποστολή Email από Excel

[Exceler]

Καλημέρα σε όλους!

Γνωρίζει κάποιος πώς μπορώ να στείλω αυτόματα το τρέχον φύλλο Excel
σαν συνημμένο στο Outlook (Exchange Server) σε διαφορετικές διευθύνσεις;

Οι διευθύνσεις βρίσκονται στην περιοχή Z2:Z20
Επίσης τα Email δεν πρέπει να αποσταλλούν σαν CC ή BCC.

Ευχαριστώ εκ των προτέρων.

Λάκης

[Tasos]

Αγαπητέ Λάκη καλημέρα.

Ο παρακάτω κώδικας αποθηκεύει το επιθυμητό φύλλο Excel σε νέο βιβλίο και το στέλνει στο
Outlook σαν συνημμένο προσθέτοντας τους παραλήπτες που βρίσκονται σε ορισμένη περιοχή του
βιβλίου (MailAddresses).

Αφού λοιπόν ορίσεις την περιοχή "MailAddresses" στο βιβλίο εργασίας σου που θα περιέχει τους παραλήπτες, πέρασε τον παρακάτω κώδικα σε μια λειτουργική μονάδα, κάνε τις απαραίτητες προσαρμογές (όνομα φύλλου, θέμα, Όνομα του νέου αρχείου, ενδεχομένως κείμενο στο κυρίως σώμα του Μηνύματος) και κάνε τις δοκιμές σου.

Ο κώδικας αυτός λειτουργεί και στο Office 2003 και στο Office 2007 σε περιβάλλον Exchange.
Αν δεν υπάρχει Exchange Server, τότε τα πράγματα διαφοροποιούνται και θα χρειαστεί διαφορετικός
χειρισμός.

Φιλικά

Τάσος

Option Explicit



Sub Send_Excel_Sheet_via_Outlook()

    Dim msg As Object, oApp As Object, _

    wbFullName$, strRecipients$, i%, SheetName$

    

    SheetName = Sheets(1).Name

    wbFullName = Environ("temp") & "\" & SheetName & _

    Replace(Format(Now, "_dd_mm_yy_hh:mm:ss") & ".xls", ":", "_")

    

    With Range("MailAddresses")

    For i = 1 To .Count

            If .Item(i) <> vbNullString Then _

            strRecipients = strRecipients & .Item(i) & ";"

        Next

    End With

    

    Sheets(1).Copy

    

    With ActiveWorkbook

        .SaveAs Filename:=wbFullName

        .Close

    End With



    Set oApp = CreateObject("Outlook.Application")

    Set msg = oApp.CreateItem(0)

    

    With msg

        .To = strRecipients

        .Subject = SheetName & " " & Date & " " & Time ' Προσάρμοσε το κείμενο του θέματος στα μέτρα σου.

        .Attachments.Add wbFullName

        .Body = "This is a Test." & vbLf & "Please ignore." ' Προσάρμοσε το κείμενο στα μέτρα σου.

        .Display ' εμφανίζει το μήνυμα

        '.Send ' αποθηκεύει το μήνυμα στο φάκελο  του Outlook "OutBox"

    End With

    

    Set oApp = Nothing

    Set msg = Nothing

End Sub
        

[Exceler]

Καλησπέρα σε όλους.

Φίλε Τάσο, ο κώδικας σου με βόλεψε μια χαρά!

Όρισα την περιοχή "MailAddresses" αλλά σε διαφορετικό φύλλο για να μην εμφανίζεται στο συνημμένο, αφαίρεσα το ".Display", ενεργοποίησα το ".Send" και.. αυτό ήταν!

Λειτουργεί άψογα!

Σ ευχαριστώ πολύ.

Με εκτίμηση

Λάκης

Καλημέρα ,

Εκανα καποια πειράματα και τελικα καπου κατεληξα με την αποστολη e-mail βαση ημερομηνιας αλλά ΑΥΤΟΜΑΤΑ. Δηλαδη με το που ανοιγουμε το excel αυτο στελνει ενα προκαθορισμενο κειμενο χωρις να χρειαζεται να κανει κατι ο χειριστης. Ειναι παρα πολυ βολικό.

Το επισυνάπτω για να με βοηθησει οποιος μπορει στο προβληματακι που εχω.

Στελνει e-mail Μόνο στο κελί Α2 τι χρειαζεται να γραχω στον VBA κώδικα ώστε να στελνει email σε όλα τα Α κελιά ?

Σας παραθετω και τον κώδικα , εστιαζω το προβλημα με την μικρη εμπειρια μου στο

Set Rng = Worksheets("Sheet1").Range("A2")


Ολος ο κώδικας

Sub CheckForExpiryDates()

Dim Cell As Range
Dim Mail_Msg As String
Dim Mail_Subj As String
Dim Rng As Range
Dim RngEnd As Range

Mail_Subj = "thema_E-mail"
Mail_Msg = "keimeno_email"


Set Rng = Worksheets("Sheet1").Range("A2")
Set RngEnd = Rng.Parent.Cells(Rows.Count, Rng.Column).End(xlUp)
Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Rng.Parent.Range(Rng, RngEnd))

For Each Cell In Rng.Cells
If Cell.Offset(0, 2) < Now() Then
SendEmail Cell.Offset(0, 1), Mail_Subj, Mail_Msg
End If
Next Cell

End Sub


ΥΓ : Επειδη δεν μπορώ να ανοιξω νεο θεμα αν επιθυμουν οι διαχειριστες και ειναι σωστο το excel που ανεβαζω ας το μεταφερουν στα παραδειγματα για να βοηθηθει κι αλλος κοσμος στην κοινότητα που θελει κατι αντιστοιχο

[Tasos]

Καλησπέρα σε όλους!

Βασίλη, Στα χρήσιμα του φόρουμ χρησιμοποιούμε δικά μας παραδείγματα.


Το παράδειγμα που ανέβασες, ναι λειτουργεί μόνο κάτω από συγκεκριμένες
συνθήκες.
Για παράδειγμα, η εντολή Send δεν θα λειτουργήσει σωστά σε Outlook 2003
επειδή μπλοκάρεται από προειδοποιητικό μήνυμα ασφάλειας (δεν είναι ότι καλύτερο σε έναν αυτοματισμό) και χρειάζεται την κατάλληλη ενέργεια από τον χρήστη για να συνεχιστεί ο κώδικας.

Επίσης, ακόμα και αν αποσταλεί προγραμματιστικά (σε νεότερες εκδόσεις του Outlook ο περιορισμός απενεργοποιείται) δεν είναι σίγουρο ότι τα μηνύματα θα αποσταλούν άμεσα.

Δες ένα παράδειγμα κώδικα αποστολής Email (υπάρχει και στο συνημμένο) παρακάτω:

Τάσος

Option Explicit



Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)



Private Declare Function ShellExecute _

                          Lib "shell32.dll" _

                              Alias "ShellExecuteA" ( _

                              ByVal Hwnd As Long, ByVal lpOperation As String, _

                              ByVal lpFile As String, ByVal lpParameters As String, _

                              ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long



Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _

                                    ByVal lpClassName As String, _

                                    ByVal lpWindowName As String) As Long



Private OL As Object



Sub MakeOLBinding()

' Δεν είναι απόλυτο ότι το Outlook θα στείλει τα μηνύματα που δημιουργούμε προγραμματιστικά

' Με την παρακάτω μέθοδο ανοίγουμε την εφαρμογή και μετά δημιουργούμε το αντικείμενο

' με τη μέθοδο GetObject().

' Έτσι, τα μηνύματα δεν θα παραμείνουν στο φάκελο "Outbox" αλλά θα αποσταλλούν άμεσα

' είτε αν ο χρήστης πατήσει "Αποστολή",

' είτε το μήνυμα αποσταλλεί προγραμματιστικά (Outlook > 2003 + oMail.Send)



    Dim StartOL As Long

    If FindWindow(vbNullString, "Microsoft Outlook") = 0 Then

        StartOL = ShellExecute(0, "open", "outlook.exe", "", "", 3)

    End If

    On Error Resume Next

    Do

        If Err <> 0 Then Err.Clear

        Set OL = GetObject(, "Outlook.Application")

        If Not OL Is Nothing Then

            OL.ActiveWindow.WindowState = 1

            Exit Do

        End If

        Sleep 100

    Loop



End Sub



Sub CheckForExpiryDates()

    Dim strBody As String, strSubj As String, rng As Range

    strSubj = "Το θέμα του μηνύματος ή τιμή από κάποιο κελί"

    strBody = "Το κείμενο του μηνύματος ή τιμή από κάποιο κελί"

    Set rng = Sheet1.Range("B2:B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row)

    If rng.Row > 1 Then

        SendEmail rng, strSubj, strBody

    End If

End Sub



Sub SendEmail(rngAddresses As Range, _

              strSubj As String, _

              strBody As String)



    Dim oMail As Object, c As Range



    For Each c In rngAddresses

        DoEvents

        If c.Offset(, 1) <= Date And c.Offset(, 2) <> "a" Then

            If OL Is Nothing Then MakeOLBinding

            Set oMail = OL.CreateItem(0&)

            With oMail

                .To = c.Text

                .Subject = strSubj

                .Body = strBody

                On Error Resume Next

                .Display

                ' Για εκδόσεις Outlook 2003 όπου η δυνατότητα άμεσης αποστολής (oMail.Send)

                ' μπλοκάρεται από προειδοποιητικό μήνυμα ασφάλειας.

                ' .Send    ' Θα λειτουργήσει σε εκδόσεις Outlook νεότερες του 2003

                ' Όποιος θελήσει να στείλει E-Mail αυτόματα μέσω Outlook 2003 με τη μέθοδο της

                ' άμεσης αποστολής (oMail.Send), θα πρέπει να γράψει παρόμοιο κώδικα

                ' και στο Outlook (μόνο για προχωρημένους).

                ' Σε έκδοση Outlook 2003 Θα μπορούσε να λειτουργήσει μόνο σε περιβάλον Exchange

            End With

            If Err = 0 Then

                c.Offset(, 2) = "a"

                'c.Offset(, 2) = μια στήλη μορφοποιημένη με γραμματοσειρά "Marlett"

                ' όπου το "a" αυτής της γραμματοσειράς έχει τη μορφή ενός τικ και

                'αποτελεί ένδειξη ότι το μήνυμα απεστάλη 'η τουλάχιστον δημιουργήθηκε.

            Else

                c.Offset(, 2) = "r"

                Err.Clear

            End If

        End If

    Next

    If Not OL Is Nothing Then Set OL = Nothing

End Sub


        

Τασο καλησπέρα ,

Για ακομα μια φορα ησουν κατατοπιστικότατος.

Αυτο που λες οντως ισχυει καθως καποια τα κοβει ομως σε συνεχεια πειραματισμων σημερα σε office 2003 παντα ειδα βαζοντας το Α2:A500 στον κωδικα βγάζει ενα debug error ομως τα στελνει τα email Κανονικά.

Το αναφερω απλά για να γνωριζουν οσοι ασχοληθουν με κατι παρομοιο .

Σε ευχαριστω για τον κωδικα θα το μελετησω.