Hallo,
ich möchte Aufgrund einer Kundennummer alle dazugehörigen Mail Adressen in einer Listbox anzeigen lassen.
Hintergrund ist , dass ich eine Angebotstabelle habe und per Mail jeweils die nötigen Wiedervorlagen abarbeite. Allerdings werden in dieser Tabelle nicht die Mailadressen übergeben.
Ich habe das soweit gelöst, aber bekomme nur immer den ersten Treffer der Mailadressen. Hat der Kunde mehrere, möchte ich gerne auswählen.
anbei mein zusammengebasteltes Script.
Dim Notes As Object
Dim Maildb As Object
Dim objNotesDocument As Object
Dim objNotesField As Object
Dim MailDoc As Object
Dim session As Object
Dim Recipient As String
Dim e As String
Dim f As String
Dim rtitem
Dim spalte As String
Dim ant As String
Dim body As Variant
Dim betreff As String
Dim Firma As Variant
Dim info As String
On Error Resume Next
Dim kdnr As String
ant = InputBox("welche Zeile ?", "Zeile...", "5")
betreff = "Angebotsnachfrage zu unserm Angebot " & Cells(ant, "c") & " vom " & Cells(ant, "N") '"Mein Betreff" ' die Betreffzeile
body = Cells(ant, "x")
Firma = Cells(ant, "g") ' Firmen Nr. und Name Cells(ant, "F") & " " & Cells(ant, "g")
kdnr = Cells(ant, "f") ' kundennummer
' --------------- Auslesen der mailadresse ------------ in Tabelle Kundendaten
Application.ScreenUpdating = False
Dim b As Integer
Dim SuchWert As String
Dim objExcel As New Excel.Application
Dim objSheet As Excel.Worksheet
Dim mail As String
Dim z As Integer
objExcel.Workbooks.Open ""
Set objSheet = objExcel.Worksheets("Email Adressen")
mail = ""
SuchWert = kdnr 'InputBox("Kundennummer eingegen ", "Mail Adresse suchen....", "180415") 'Worksheets("Telefonate").Cells(b, 4)
z = Range("B1000").End(xlUp).Row
For c = z To 2 Step -1
If objSheet.Cells(c, 2) = SuchWert Then
mail = objSheet.Cells(c, 7)
GoTo sprung
Else
End If
Next c
' Next b
sprung:
objExcel.ActiveWorkbook.Close SaveChanges:=False
objExcel.Quit
Set objExcel = Nothing
Set objSheet = Nothing
Application.ScreenUpdating = True
'------------------------- ende suchen Mail Adresse ---------------------------
' nicht mehr benötigt
'If Firma = "#NV" Then
' Firma = Cells(ant, "F") & " " & Cells(ant, "g") & "Bitte Mailadresse einfügen!"
' Else
' End If
' Texterzeugung
Dim nr As Variant
nr = ant
Dim Zelle As Range
Dim Zeile1 As Variant
Dim Zeile2 As Variant
Dim Zeile3 As Variant
Dim Zeile4 As Variant
Dim Zeile5 As Variant
Dim Zeile6 As Variant
Dim Textblock As Variant
Dim sverw As Variant
Dim sverwnr As String
Zeile1 = "Sehr geehrte Damen und Herren" & vbNewLine & vbNewLine
Zeile2 = "am " & Cells(nr, "N") & " haben wir für Sie unser Angebot " & Cells(nr, "C") & " erstellt. " & vbNewLine
Zeile3 = "Diesbezüglich möchte ich mich über den aktuellen Stand dieses Angebotes mit der Objektbezeichnung: " & Cells(nr, "k") & ", erkundigen." & vbNewLine
Zeile4 = "Die Laufzeit unseres Angebotes geht noch bis zum " & Cells(nr, "m") & "; danach ist ev. eine Nachkalkulation erforderlich!" & vbNewLine & vbNewLine
Zeile5 = "Über eine Rückmeldung Ihrerseits wäre ich Ihnen dankbar."
Textblock = Zeile1 & Zeile2 & Zeile3 & Zeile4 & Zeile5
body = Textblock
info = MsgBox(Firma & vbNewLine & vbNewLine & body, vbOKOnly, "Mailvorbereitung an " & mail)
Rows(ant).Interior.ColorIndex = 33
Set Notes = CreateObject("Notes.NotesSession")
Set Maildb = Notes.GETDATABASE("", "")
Maildb.OPENMAIL
Set objNotesDocument = Maildb.CreateDocument
Set objNotesField = objNotesDocument.APPENDITEMVALUE("sendTo", mail) 'calls a function to return the SendTo
Set objNotesField = objNotesDocument.APPENDITEMVALUE("Subject", betreff) ' geht
Set Workspace = CreateObject("Notes.NotesUIWorkspace")
Call Workspace.EDITDOCUMENT(True, objNotesDocument)
Set uidocument = Workspace.CurrentDocument
Call uidocument.gotoField("Body") ' geht
Call uidocument.insertText(body) 'calls a function to return the body contents.
AppActivate "Lotus Notes"
End Sub