Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Forumthread: Wenn zweite Mail Adresse dann CC

Wenn zweite Mail Adresse dann CC
12.08.2021 21:38:31
Sabbel
Hallo,
ich habe folgendes Skript um aus den drei feldern die EMail Adresse auszulesen.
Das funktioniert. Die erste gefundene Adresse wird als Mail Adresse übernommen,
Nun soll aber wenn eine zweite mail Adresse in den Feldern steht diese ins CC geschrieben werden.
Kann mir jemand helfen?

Option Explicit
Private Function IsValidMailAddress(ByVal strAddress As String) As Boolean
Dim oRegExp As Object
Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
.Pattern = "[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\.[a-z0-9!#$%&'*+/=?^_`{|" & _
"}~-]+)*@(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\.)+[a-z0-9](?:" & _
"[a-z0-9-]*[a-z0-9])?"
.IgnoreCase = True
IsValidMailAddress = .Test(strAddress)
End With
Set oRegExp = Nothing
End Function
Sub Mail()
Dim strRec As String
Dim OutApp, OutMail As Object
Dim Ws As Worksheet: Set Ws = Workbooks("Test.xlsm").Worksheets("Tabelle1")
If Not IsValidMailAddress(strRec) Then strRec = Ws.Range("Telefon1_Eingabe").Text
If Not IsValidMailAddress(strRec) Then strRec = Ws.Range("Telefon2_Eingabe").Text
If Not IsValidMailAddress(strRec) Then strRec = Ws.Range("Telefon3_Eingabe").Text
If Not IsValidMailAddress(strRec) Then
strRec = InputBox("Bitte Empfängeradresse angeben:", "Mail")
'If strRec Not vbOK Then Then Exit Sub
End If
' Bezug zu Outlook herstellen...
Set OutApp = CreateObject("Outlook.Application")
' ...neue E-Mail erzeugen
Set OutMail = OutApp.CreateItem(0)
' Werte den Eigenschaften zuweisen...
OutMail.To = strRec
OutMail.CC = ""
OutMail.BCC = ""
OutMail.GetInspector.Display
End Sub
https://www.herber.de/bbs/user/147593.xlsm
Liebe Grüße
Sabbel
Anzeige

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Wenn zweite Mail Adresse dann CC
12.08.2021 22:29:08
Yal
Hallo Sabbel,
Function IsValidMailAddress habe ich nichts geändert, daher hier nicht wieder augeführt.

Private Function UBound0(Arr) As Long
'gibt -1 zurück, wenn Arr noch nicht dimensioniert (ansatt Fehler)
On Error Resume Next
UBound0 = -1
UBound0 = UBound(Arr)
End Function
Sub Mail()
Dim strRec() As String
Dim ValidCount As Integer
Dim OutApp, OutMail As Object
Dim Ws As Worksheet
Dim i
Set Ws = Workbooks("Test.xlsm").Worksheets("Tabelle1")
For i = 1 To 3
If IsValidMailAddress(Ws.Range("Telefon" & i & "_Eingabe").Text) Then
ReDim Preserve strRec(UBound0(strRec) + 1)
strRec(UBound(strRec)) = Ws.Range("Telefon" & i & "_Eingabe").Text
End If
Next
If UBound0(strRec) = -1 Then
ReDim strRec(0)
strRec(0) = InputBox("Bitte Empfängeradresse angeben:", "Mail")
If Not IsValidMailAddress(strRec(0)) Then
MsgBox "Eingegeben Mailadresse nicht valid", vbExclamation + vbOKOnly, "Exitus!"
Exit Sub
End If
End If
' Bezug zu Outlook herstellen...
Set OutApp = CreateObject("Outlook.Application")
' ...neue E-Mail erzeugen
Set OutMail = OutApp.CreateItem(0)
' Werte den Eigenschaften zuweisen...
OutMail.To = strRec(0)
OutMail.CC = Mid(Join(strRec, ";"), Len(strRec(0)) + 2)
OutMail.BCC = ""
OutMail.GetInspector.Display
End Sub
Kommst Du mit dem Code zurecht? Lass es in Schritt-Modus laufen (F8) beim geöffneten Lokal-Fenster (Ansicht, Lokal-Fenster), so kannst Du die Zustände der Variablen beobachten.
VG Yal
Anzeige
AW: Wenn zweite Mail Adresse dann CC
13.08.2021 08:11:02
Herbert_Grom
Hallo,
gib mal der Zelle D7 diesen Namen (Telefon3_Eingabe), dann sollte auch dein Makro funktionieren!
Servus
Vielen Dank ... owT
15.08.2021 16:46:15
Sabbel
AW: Vielen Dank ... owT
15.08.2021 16:48:53
Herbert_Grom
Vielen Dank was? Geht oder nicht?
Anzeige
;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige