Lotus Notes- Nur an bestimmte Empfänger senden
26.10.2015 09:30:58
Benni
ich bin VBA-Neuling und habe mir einen Code zusammengesucht und angepasst. Dank der Hilfe von Martin, kann ich über Excel an alle Empfänger, die in der Liste stehen eine E-Mail verschicken, das funktionioniert auch echt klasse! Allerdings hätte ich jetzt gerne, dass nur an diejenige eine E-Mail geschickt wird, die in der Spalte "geantwortet" KEIN "ja" enthalten.
Meine Tabelle ist wie folgt aufgebaut:
Spalte A:Name
Spalte B:PLZ
Spalte C:Ort
Spalte D:Land
Spalte E:Anrede
Spalte F:"Ansprechpartner Vorname"
Spalte G:"Ansprechpartner Nachname"
Spalte H: Sprache
Spalte I:E-Mail
Spalte J:geantwortet
Mein Code sieht wie folgt aus:
Sub lotus()
Dim sText As Variant, sEmpfang As Variant, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject, ws As Object
Dim x As Integer, y As Integer, Msg As Integer
Dim sKopie As String, AttachMe As Object, DerAnhang As Object
Dim user As String, server As String, mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant, vBlind As Variant, sAnhang As String
On Error GoTo Fehler
sText = Range("B4") & vbCrLf ' Text in Zelle B4
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
sBetrifft = Range("B3") ' Überschrift in Zelle b3
'Wenn du keine Kopie od Blindkopie versenden willst, dann grad weglassen
sKopie = Range("D3") ' Einträge durch " ; " getrennt Kopietest@gmx.de
'sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
vAn = Application.Transpose(Range(Cells(12, 9), Cells(Cells(Rows.Count, 9).End(xlUp).Row, 9) _
)) ' E-Mail Adressen ab Zelle I12
sAnhang = Range("B6") ' Link aus Zelle b6
sAnhang2 = Range("B7") ' Link aus Zelle b7
sAnhang3 = Range("B8") ' Link aus Zelle b8
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ") 'bcc Array
Set session = CreateObject("notes.notessession") ' Notes muss gestartet sein
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.GetDatabase(server, mailfile)
Set doc = db.createdocument()
doc.Form = "Memo"
doc.SendTo = Join(vAn, "; ") 'an array
If Len(sKopie) > 0 Then doc.CopyTo = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' die Betreffzeile
doc.SAVEMESSAGEONSEND = True
doc.PostedDate = Now
'Die Zeilen mit dem Anhang nach hier oben verschieben, ist wichtig die Reihenfolge
If sAnhang "" Then
Set AttachMe = doc.CREATERICHTEXTITEM("Attachment")
Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", sAnhang)
Set DerAnhang2 = AttachMe.EMBEDOBJECT(1454, "", sAnhang2)
Set DerAnhang3 = AttachMe.EMBEDOBJECT(1454, "", sAnhang3) ',"Attachment" wird nicht benö _
tigt
End If
Set ws = CreateObject("Notes.NotesUIWorkspace") ' **durch das öffnen des Dokumentes durch _
NotesUIWorkspace**
Call ws.EDITDOCUMENT(True, doc) ' **erreicht man das die eingestellte Signatur _
aus den **
Set doc = ws.CURRENTDOCUMENT ' **Lotus Notes Optionen eingefügt wird _
Call doc.GOTOFIELD("Body")
Call doc.insertText(sText)
Call doc.Send(True)
Call doc.Close 'Schliesst das gesendete Formular
Call doc.Save(True, True)
Aufraeumen:
On Error Resume Next
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set ws = Nothing
Set doc = Nothing
Set db = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub
Vorab vielen Dank für eure Hilfe!
Grüße
Benni
P.S. es wäre super, wenn ich im nächsten Schritt es noch schaffe, dass wenn in Spalte H "englisch" steht, der Text nicht aus Zelle B4, sondern aus D4 genommen wird :)