Das könnte dann so aussehen:
Annahme du hast zwei Tabellen
1.) "Adressen" mit den Feldern
"LfdNr" = Key numerisch
"Email" = e-mail-Adresse
"Anrede" = Anredeschlüssel 1 = Herr, 2 = Frau, 3 = Firma
"Name" = Kunden-Nachname
2.) "Textzeilen" mit den Feldern
"LfdNr" = Key numerisch
"Text" = Bei LfdNr = 0 ist es der Betreff, sonst Textzeile
Tabellen sind aufsteigend sortiert
Option Compare Database
Option Explicit
Option Base 0
Function TestMail()
Dim Anlage As String, Empfaenger As String, Betreff As String
Dim Test, TextTab(), TextCnt As Long, RecCnt As Long, Anrede As String
Dim myOlApp, myNameSpace
Dim Db As Database
Dim Tb As Recordset
Set Db = CurrentDb
Set Tb = Db.OpenRecordset("Textzeilen")
ReDim TextTab(Tb.RecordCount)
RecCnt = 0
Betreff = ""
Tb.MoveFirst
Do Until Tb.EOF
If Tb.Fields("LfdNr") = 0 Then
Betreff = Tb.Fields("Text")
Else
RecCnt = RecCnt + 1
TextTab(RecCnt) = Tb.Fields("Text") & Chr$(10)
End If
Tb.MoveNext
Loop
TextCnt = RecCnt
Tb.Close
Set Tb = Db.OpenRecordset("Adressen")
RecCnt = 0
Tb.MoveFirst
Do Until Tb.EOF
RecCnt = RecCnt + 1
Empfaenger = Tb.Fields("Email")
Anrede = "Sehr geehrte"
If Tb.Fields("Anrede") = 1 Then
Anrede = Anrede & "r Herr " & Tb.Fields("Name")
ElseIf Tb.Fields("Anrede") = 2 Then
Anrede = Anrede & " Frau " & Tb.Fields("Name")
Else
Anrede = Anrede & " Damen und Herren"
End If
TextTab(0) = Anrede & Chr$(10) & Chr$(10)
Test = procEMailSchreiben(Anlage, Empfaenger, TextTab(), TextCnt, Betreff)
Tb.MoveNext
Loop
Tb.Close
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
myNameSpace.GetDefaultFolder(olFolderOutbox).Display
End Function
Function procEMailSchreiben(strAtt As String, strEmpfaenger As String, tabText(), tabAnz As Long, strBetreff As String) As Boolean
Dim OL As Outlook.Application
Dim objMail As MailItem
Dim Cnt As Long
On Error GoTo ErrorHandler
Set OL = New Outlook.Application
Set objMail = OL.CreateItem(olMailItem)
With objMail
For Cnt = 0 To tabAnz
.Body = .Body & tabText(Cnt)
Next Cnt
.To = strEmpfaenger
.Subject = strBetreff
If strAtt <> "" Then
.Attachments.Add strAtt
End If
'.DeferredDeliveryTime = 10000
.Send
End With
Set OL = Nothing
Set objMail = Nothing
procEMailSchreiben = True
Exit Function
ErrorHandler:
MsgBox "Der folgende Fehler ist aufgetreten: " & Err.Number & _
" - " & Err.Description, vbCritical + vbOKOnly
procEMailSchreiben = False
End Function
unter Verweise musst du VBA und die Object libraries von Access, Office und Outlook sowie Microsoft DAO 3.6 Object library haben.
