nach kriterien email senden
amintire
weiß leider nicht wie ich zum alten Beitrag verlinken kann, daher einen neuen Beitrag.
Der alte Beitrag hat das gleiche Thema und ist vom vom 10.10.2011 19:16:5
Folgendes Problem, möchte das die E-Mails die gesendet werden an 3 Personen in Kopie auch immer gesendet werden, beim Code ist nur eine Mail Adresse möglich. Was bzw. wie muss ich das ändern bzw. anpassen? Vielen Dank für Eure Hilfe.
Anbei der Code:
**********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Const cstrMyAddress As String = "deine.mail@adresse.com"
Sub SendNotesMail()
'Variablendeklaration gehört immer an den Anfang!
Dim Maildb As Object, MailDoc As Object, Session As Object, EmbedObj As Object, AttachME As Object
Dim MailDbName As String, strRecipient As String, strMsg As String, strSubj As String
Dim rng As Range
Dim lngCol As Long
On Error GoTo ErrExit
tranquilize
ActiveWorkbook.Save
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Set Session = CreateObject("Notes.NotesSession")
Set Maildb = Session.CURRENTDATABASE
With Sheets("Übersicht")
For Each rng In .Range("A3:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
If rng "" Then
strRecipient = ""
If IsValidMailAddress(rng.Offset(0, 3).Text) Then
If Not IsDate(rng.Offset(0, 7)) Then
For lngCol = 4 To 6
If rng.Offset(0, lngCol) = "x" Then
strRecipient = rng.Offset(0, 3).Text
strMsg = "Sehr geehrte" & IIf(rng = "Herr", "r ", " ") & rng.Text & " " & _
rng.Offset(0, 1).Text & " " & rng.Offset(0, 2).Text & "!" & _
vbCrLf & vbCrLf & Sheets(.Cells(2, lngCol + 1).Text).Range("A2").Text
strSubj = Sheets(.Cells(2, lngCol + 1).Text).Range("A1").Text & _
" - " & rng.Offset(0, 1).Text & " " & rng.Offset(0, 2).Text
Exit For
End If
Next
End If
If strRecipient "" Then
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.sendto = strRecipient
MailDoc.CopyTo = cstrMyAddress
MailDoc.Subject = strSubj
MailDoc.Body = strMsg
MailDoc.PostedDate = Now
MailDoc.SEND 0, strRecipient
rng.Offset(0, 7) = Now
End If
Else
rng.Offset(0, 7) = "ungültige Mailaddresse!"
End If
End If
Next
End With
ErrExit:
tranquilize True
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
End Sub
Public 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
Public Sub tranquilize(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
If Modus Then
With Err
If .Number 0 Then
MsgBox IIf(Erl, vbLf & "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbLf & _
.Description, vbExclamation, "Fehler"
End If
.Clear
End With
End If
End Sub
Lieben Gruß Amina