Neuigkeiten:

Wenn ihr euch für eine gute Antwort bedanken möchtet, im entsprechenden Posting einfach den Knopf "sag Danke" drücken!

Mobiles Hauptmenü

email aus Access versenden über Thunderbird

Begonnen von abodef, März 08, 2020, 17:43:58

⏪ vorheriges - nächstes ⏩

abodef

Hallo,

könnte mir jemand den folgenden Code so umarbeiten, dass ich die Mails nicht mehr über Outlook, sondern über Thunderbird versenden kann. ich bin auf VBA leider so gar nicht firm, arbeite mich aber langsam ein.  ::)

Private Sub Befehl_4_Click()

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
   
    Dim emailTo As String
    Dim emailSubject As String
    Dim emailText As String

    Dim outApp As Outlook.Application
    Dim outMail As Outlook.MailItem
    Dim outlookStarted As Boolean
       
   
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If outApp Is Nothing Then
        Set outApp = CreateObject("Outlook.Application")
        outlookStarted = True
    End If

    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT Anrede1, Vorname1, Name1, Mail, Betreff,  mailtxtText, zusatzSignatur" & " FROM qry_Mailing")
    Do Until rs.EOF

        emailTo = Trim(rs.Fields("Vorname1").Value & " " & rs.Fields("Name1").Value) & _
                    " <" & rs.Fields("Mail").Value & ">"
                   
        emailSubject = Trim(rs.Fields("Betreff").Value)
               
               
        emailText = Trim(rs.Fields("Anrede1") & " " & rs.Fields("Name1").Value) & "," & vbCrLf & vbCrLf & (rs.Fields("mailtxtText")) & vbCrLf & vbCrLf & vbCrLf & (rs.Fields("zusatzSignatur"))
       
       
                   
        Set outMail = outApp.CreateItem(olMailItem)
        outMail.To = emailTo
        outMail.Subject = emailSubject
        outMail.Body = emailText
        outMail.Display

        rs.MoveNext
    Loop
   
    rs.Close
    Set rs = Nothing
    Set db = Nothing
   
    If outlookStarted Then
        outApp.Quit
    End If
   
    Set outMail = Nothing
    Set outApp = Nothing
   
End Sub