Email über Outlook bestimmter Absender

Hallo Excelfreunde,
ich konnte meine Excel-Datei davon überzeugen, dass sie mir in Abhängigkeit von Fälligkeiten bestimmter Servicetermine Emails verschickt. Dazu verwende ich folgenden Code:


Sub Email()
For i = 8 To 40
If Worksheets("LKW").Cells(i, 3)  "" Then
If Date >= Worksheets("LKW").Cells(i, 3) And Worksheets("LKW").Cells(i, 4) = "" Then
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Set objOutlook = New Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
.Recipients.Add Worksheets("LKW").Range("B3").Value
.Subject = Worksheets("LKW").Range("A1").Value
.Body = Worksheets("LKW").Cells(i, 5).Value
End With
If MsgBox("Email an " & Worksheets("LKW").Range("D3").Value & " " & Worksheets(" _
LKW").Range("E3").Value & vbNewLine & vbNewLine & Worksheets("LKW").Range("A1").Value & vbNewLine & vbNewLine & Worksheets("LKW").Cells(i, 5).Value & vbNewLine & vbNewLine & "Soll diese Email gesendet werden?" & vbNewLine & vbNewLine & "(Die Datei muss danach gespeichert werden!)", vbOKCancel, "Eine Emailnachricht ist fällig") = vbOK Then
objMail.Send
Worksheets("LKW").Cells(i, 4) = Date
End If
End If
End If
Next i
End Sub

In Outlook habe ich vier Emailadressen angelegt. Ich möchte, dass die Absenderadresse der Email diejenige ist, welche auf "@gmx.de" endet. Zur Zeit wird als Absender immer die "@outlook.de"-Adresse benutzt. Ich habe gelesen, dass man zuerst alle gespeicherten Absenderadressen in Outlook auslesen muss und dann die entspechende Absenderadresse auswählen kann.
Dies zu bewerkstelligen übersteigt aber bei weitem meinen Horizont. Auch im Netz vorhandene Beispiele anzupassen und in meinen Code einzupflegen bekomme ich nicht hin.
Desweiteren wird die gesendete Email nicht im Standardordner "Gesendete Elemente" abgelegt. Auch dass ist für mich schier unmöglich zu lösen.
Ich weiß, es ist ganz schön viel verlangt, wenn ich euch bitte, mir diese Funktionen in mein Script einzubauen. Aber ich schaffe es selbst nicht.
Ich würde mich sehr freuen, wenn jemand Zeit findet, sich meinem Script anzunehmen.
Bis dahin und viele Grüße in die Runde
Kulo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kulo,
würde ich so machen:

Option Explicit

Public Sub Email()

    Dim i As Long
    Dim strSenderAddress As String
    Dim objOutlook As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim objAccount As Outlook.Account

    Set objOutlook = New Outlook.Application

    For Each objAccount In objOutlook.Session.Accounts
        If objAccount.SmtpAddress Like "*@gmx.de" Then strSenderAddress = objAccount.SmtpAddress
    Next

    If strSenderAddress <> vbNullString Then

        With Worksheets("LKW")

            For i = 8 To 40

                If Not IsEmpty(.Cells(i, 3).Value) Then

                    If Date >= .Cells(i, 3).Value And IsEmpty(.Cells(i, 4).Value) Then

                        If MsgBox("Email an " & .Range("D3").Value & " " & .Range("E3").Value & vbLf & vbLf & _
                            .Range("A1").Value & vbLf & vbLf & .Cells(i, 5).Value & vbLf & vbLf & _
                            "Soll diese Email gesendet werden?" & vbLf & vbLf & _
                            "(Die Datei muss danach gespeichert werden!)", vbOKCancel, _
                            "Eine Emailnachricht ist fällig") = vbOK Then

                            Set objMail = objOutlook.CreateItem(olMailItem)

                            With objMail

                                .SentOnBehalfOfName = strSenderAddress

                                .Recipients.Add Worksheets("LKW").Range("B3").Value

                                .Subject = Worksheets("LKW").Range("A1").Value

                                .Body = Worksheets("LKW").Cells(i, 5).Value

                                .Send

                            End With

                            .Cells(i, 4).Value = Date

                        End If
                    End If
                End If
            Next i
        End With
    Else
        MsgBox "Keine gmx-Adresse gefunden.", vbCritical, "Fehler"
    End If
    Set objMail = Nothing
    Set objOutlook = Nothing
End Sub

Gruß
Nepumuk

Ihre Nachricht hat einige oder alle Empfänger nicht erreicht. Betreff: Servicetermin / Fälligkeiten Gesendet am: 15.02.19 20:13 Folgende(r) Empfänger kann/können nicht erreicht werden: 'xxxxx@gmx.de' am 15.02.19 20:13 Diese Nachricht konnte nicht gesendet werden. Sie besitzen nicht die Berechtigung, _ die Nachricht im Auftrag des angegebenen Benutzers zu senden.

Public Sub Email() Dim I As Long Dim K As Long ' Die Accountnumber der Emailadresse Dim strSenderAddress As String ' Kann weg - oder? Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim objAccount As Outlook.Account Dim OutApp As Outlook.Application ' geht da auch objApp as ... wenn ich unten in objApp ä _ ndere Set objOutlook = New Outlook.Application Set OutApp = CreateObject("Outlook.Application") ' Schleife zum Auslesen der in Outlook hinterlegten Absenderadressen und festlegen der _ Account-Nummer in Variable K For I = 1 To OutApp.Session.Accounts.Count If OutApp.Session.Accounts.Item(I) Like "*@gmx.de" Then K = I Next I ' wenn in Outlook eine Absenderadresse mit "*@gmx.de" gefunden wird, dann bekommt K einen _ Wert, ' muss die Variable am ende wieder geleert werden? If K 0 Then With Worksheets("LKW") For I = 8 To 40 If Not IsEmpty(.Cells(I, 3).Value) Then If Date >= .Cells(I, 3).Value And IsEmpty(.Cells(I, 4).Value) Then If MsgBox("Email an " & .Range("D3").Value & " " & .Range("E3").Value & _ vbLf & vbLf & _ .Range("A1").Value & vbLf & vbLf & .Cells(I, 5).Value & vbLf & vbLf _ & _ "Soll diese Email gesendet werden?" & vbLf & vbLf & _ "(Die Datei muss danach gespeichert werden!)", vbOKCancel, _ "Eine Emailnachricht ist fällig") = vbOK Then Set objMail = objOutlook.CreateItem(olMailItem) With objMail .Recipients.Add Worksheets("LKW").Range("B3").Value .Subject = Worksheets("LKW").Range("A1").Value .Body = Worksheets("LKW").Cells(I, 5).Value & "NeuerText und _ nochmal neuer text" .SendUsingAccount = OutApp.Session.Accounts.Item(K) .Send End With .Cells(I, 4).Value = Date End If End If End If Next I End With Else MsgBox "Keine gmx-Adresse gefunden.", vbCritical, "Fehler" End If Set objMail = Nothing Set objOutlook = Nothing Set OutApp = Nothing ' ist das okay? End Sub

Beliebteste Forumthreads (12 Monate)

Email über Outlook bestimmter Absender

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Email über Outlook bestimmter Absender

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread