E-Mail Funktion E-mail generieren

Hallo,
ich möchte folgendes erreichen:
in angefügter Tabelle möchte ich eine Mailfunktion integrieren. Ich stelle mir das in etwa so vor:
In der Haupttabelle 1 wird bei Doppelklick auf die Kopfspalte E-Mail Adresse(die Adresse so sortiert, dass alle E-Mail Adressenbesitzer oben stehen. Das funktioniert bereits via Makro. Ich wähle dann in der Spalte M aus wer eine Mail bekommen soll via Dropdown auf Ja. (auch das ist schon eingebaut).
Jetzt möchte ich ein Makro haben, dass dann einen E-Mail in Outlook erstellt mit folgenden Parametern.
Die meisten Parameter sind in der Tabelle 5 Vereinsstatus hinterlegt.
Als Absender, die eigene E-Mail Adresse (Tabelle5 Vereinsstatus in Zelle F2.
Diese soll auch im CC stehen.
Dann soll als Anlage die Anlage eingefügt werden, die vorher in Tabelle5 Vereinsstatus F5 ausgewählt wurde. ist nichts ausgewählt muss zwingend eine Fehlermeldung kommen.
Als E-Mail Betreff soll Tabelle5 (Vereinsstatus) F3 stehen
Als E-mail Text soll Tabelle5 (Vereinsstatus) F4 stehen.
Und alle Mitglieder in der Tabelle 1(Mitgliederliste) die in der Spalte M mit Ja ausgewählt wurden sollen ins BCC eingefügt werden.
Bitte beachten, dass die Tabelle sich noch erweitern kann mit Mitgliedern.
Auch soll Outlook danach aufgehen. Den Versand dann direkt in Outlook möchte ich händisch machen.
Wie geht das?
Danke und Gruß
Benedikt
Hier die Tabelle https://www.herber.de/bbs/user/120695.zip

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub EmailManuellAbsenden() Application.DisplayAlerts = False Dim objOutlook As Object Dim objMail As Object Dim olApp As Object Dim olOldBody As String Set olApp = CreateObject("Outlook.Application") With olApp.CreateItem(0) Set .SendUsingAccount = .Session.Accounts.Item("info@fidele-rixdorfer.de") ' _ Sendekonto vorwählen. .GetInspector.Display olOldBody = .htmlBody .To = Tabelle5.Cells(2, 6).Value 'Empfängeradresse aus Tabelle5 Zelle F2 .CC = Tabelle5.Cells(2, 6).Value 'CC aus Tabelle5 Zelle F2 .BCC = "" 'BCC Mitglieder eintragen aus .Attachments.Add Tabelle5.Cells(5, 6).Value 'Anlage aus Tabelle5 Zelle F5 .Subject = Tabelle5.Cells(3, 6).Value 'Betreff aus Tabelle5 Zelle F3 .htmlBody = Tabelle5.Cells(4, 6).Value & olOldBody 'Text aus Tabelle5 Zelle F4 End With End Sub

Option Explicit Private Type EmailDetails MyAddress As String ' 3 Then For i = 4 To lRow If .Cells(i, 13).Value = "Ja" Then adrs = adrs & "; " & .Cells(i, 12).Value End If Next i End If End With If Left(adrs, 1) = ";" Then adrs = Right(adrs, Len(adrs) - 1) GetDetails.BlindCarbonCopy = adrs End Function Public Sub NewMail() Dim oApp As Object Dim omItem As Object Dim ed As EmailDetails ed = GetDetails If ed.MyAddress = vbNullString Then Exit Sub 'Falls der Anhang fehlt If ed.Attachament = vbNullString Then MsgBox "Es gibt keinen Anhang, diese Mail ist überflüssig!", _ vbExclamation, "Attachments Missing" Exit Sub End If On Error GoTo FailedToCreateOutlookApp Set oApp = CreateObject("Outlook.Application") If oApp Is Nothing Then Exit Sub Set omItem = oApp.CreateItem(0) If omItem Is Nothing Then Exit Sub On Error Resume Next With omItem .To = ed.MyAddress 'geht an dich bis dato .CC = ed.CarbonCopy 'auch an dich .BCC = ed.BlindCarbonCopy 'an alle mit ja in Mitglieder .Subject = ed.Subject 'Betreff .Body = ed.MailBody 'Text der Mail .Attachments.Add ed.Attachament 'Anhang .Send 'Absenden End With On Error GoTo 0 FailedToCreateOutlookApp: If Err.Number 0 Then MsgBox "Outlook Instanz konnte nicht erstellt werden!" & _ vbCrLf & "Fehler ID: " & Err.Number & _ vbCrLf & "Fehler: " & Err.Description _ , vbInformation, "Outlook Fehler" End If End Sub

Hallo,
habe den Code getestet, aber eine Kleinigkeit geändert. ich habe das send in display geändert. Ich möchte schon noch das Ergebnis kontrollieren und händisch senden.
Das ist auch gut so, da ich jetzt folgendes Problem habe.
bei dem Code den ich zuvor hatte, war eine Zeile mit drin, nämlich
Set .SendUsingAccount = .Session.Accounts.Item("info@fidele-rixdorfer.de") ' Sendekonto vorwählen.
Dadurch wurde erreicht, dass sich Outlook so öffnet, dass bereits die Standardmäsige Signatur des Vereins, die bei Outlook voreingestellt st mit bei ist. Dies klappt jetzt leider nicht mehr. ich habe versucht diese Codezeile mit einzubauen, scheint aber nicht zu funktionieren.
Wo muss man das einbauen, oder wie wird es alternativ erreicht, dass Outlook die Sachen in die Mail einbaut, aber die Signatur mit berücksichtigt und auch gleich mit drin hat. E-mail als HTML formatiert.
hier nochmal der Code, falls ein anderer sich das ansieht.

Private Type EmailDetails
MyAddress       As String ' 3 Then
For i = 4 To lRow
If .Cells(i, 13).Value = "Ja" Then
adrs = adrs & "; " & .Cells(i, 12).Value
End If
Next i
End If
End With
If Left(adrs, 1) = ";" Then adrs = Right(adrs, Len(adrs) - 1)
GetDetails.BlindCarbonCopy = adrs
End Function
Public Sub NewMail()
Dim oApp    As Object
Dim omItem  As Object
Dim ed      As EmailDetails
ed = GetDetails
If ed.MyAddress = vbNullString Then Exit Sub
'Falls der Anhang fehlt
If ed.Attachament = vbNullString Then
MsgBox "Es gibt keinen Anhang, diese Mail ist überflüssig!", _
vbExclamation, "Attachments Missing"
Exit Sub
End If
On Error GoTo FailedToCreateOutlookApp
Set oApp = CreateObject("Outlook.Application")
If oApp Is Nothing Then Exit Sub
Set omItem = oApp.CreateItem(0)
If omItem Is Nothing Then Exit Sub
On Error Resume Next
With omItem
.To = ed.MyAddress 'geht an dich bis dato
.CC = ed.CarbonCopy 'auch an dich
.BCC = ed.BlindCarbonCopy 'an alle mit ja in Mitglieder
.Subject = ed.Subject 'Betreff
.Body = ed.MailBody 'Text der Mail
.Attachments.Add ed.Attachament 'Anhang
.display 'Absenden
End With
On Error GoTo 0
FailedToCreateOutlookApp:
If Err.Number  0 Then
MsgBox "Outlook Instanz konnte nicht erstellt werden!" & _
vbCrLf & "Fehler ID: " & Err.Number & _
vbCrLf & "Fehler: " & Err.Description _
, vbInformation, "Outlook Fehler"
End If
End Sub

Hier die Tabelle diesmal mit Dummydaten https://www.herber.de/bbs/user/120720.zip

Private Type EmailDetails MyAddress As String ' 3 Then For i = 4 To lRow If .Cells(i, 13).Value = "Ja" Then adrs = adrs & "; " & .Cells(i, 12).Value End If Next i End If End With If Left(adrs, 1) = ";" Then adrs = Right(adrs, Len(adrs) - 1) GetDetails.BlindCarbonCopy = adrs End Function Public Sub NewMail() Dim oApp As Object Dim omItem As Object Dim ed As EmailDetails Dim strSignatur As String Dim olOldBody As String ed = GetDetails If ed.MyAddress = vbNullString Then Exit Sub 'Falls der Anhang fehlt If ed.Attachament = vbNullString Then MsgBox "Es gibt keinen Anhang, diese Mail ist überflüssig!", _ vbExclamation, "Attachments Missing" Exit Sub End If On Error GoTo FailedToCreateOutlookApp Set oApp = CreateObject("Outlook.Application") If oApp Is Nothing Then Exit Sub Set omItem = oApp.CreateItem(0) If omItem Is Nothing Then Exit Sub On Error Resume Next With omItem .To = ed.MyAddress 'geht an dich bis dato .CC = ed.CarbonCopy 'auch an dich .BCC = ed.BlindCarbonCopy 'an alle mit ja in Mitglieder .Subject = ed.Subject 'Betreff .Body = ed.MailBody 'Text der Mail .Attachments.Add ed.Attachament 'Anhang .ReadReceiptRequested = True .Display 'Mail nur anzeigen, wird händisch über Outlook versendet 'Cursor ans Ende der EMail setzen VBA.SendKeys "^{END}", True .olOldBody 'Name der gespeicherten Signatur - bitte anpassen strSignatur = "fidele-signatur" 'Einfügen einer bestimmten Signatur .GetInspector.CommandBars.Item("Insert").Controls("Signatur").Controls(strSignatur). _ Execute End With On Error GoTo 0 FailedToCreateOutlookApp: If Err.Number 0 Then MsgBox "Outlook Instanz konnte nicht erstellt werden!" & _ vbCrLf & "Fehler ID: " & Err.Number & _ vbCrLf & "Fehler: " & Err.Description _ , vbInformation, "Outlook Fehler" End If End Sub

Public Sub NewMail() Dim oApp As Object Dim oAcc As Object Dim omItem As Object Dim ed As EmailDetails ed = GetDetails If ed.MyAddress = vbNullString Then Exit Sub 'Falls der Anhang fehlt If ed.Attachament = vbNullString Then MsgBox "Es gibt keinen Anhang, diese Mail ist überflüssig!", _ vbExclamation, "Attachments Missing" Exit Sub End If On Error GoTo FailedToCreateOutlookApp Set oApp = CreateObject("Outlook.Application") If oApp Is Nothing Then Exit Sub Set oAcc = oApp.Session.Accounts.Item("info@fidele-rixdorfer.de") If oAcc Is Nothing Then Exit Sub Set omItem = oApp.CreateItem(0) If omItem Is Nothing Then Exit Sub On Error Resume Next With omItem .To = ed.MyAddress 'geht an dich bis dato .CC = ed.CarbonCopy 'auch an dich .BCC = ed.BlindCarbonCopy 'an alle mit ja in Mitglieder .Subject = ed.Subject 'Betreff .HtmlBody = ed.MailBody 'Text der Mail .Attachments.Add ed.Attachament 'Anhang .SendUsingAccount = oAcc .Display 'Absenden End With On Error GoTo 0 FailedToCreateOutlookApp: If Err.Number 0 Then MsgBox "Outlook Instanz konnte nicht erstellt werden!" & _ vbCrLf & "Fehler ID: " & Err.Number & _ vbCrLf & "Fehler: " & Err.Description _ , vbInformation, "Outlook Fehler" End If End Sub

Beliebteste Forumthreads (12 Monate)

E-Mail Funktion E-mail generieren

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

E-Mail Funktion E-mail generieren

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread