Seite 1 von 1

Mehrere Mail Empfänger in die Outlook Adresszeile

BeitragVerfasst: 14. Sep 2021, 07:45
von Dirk2003
Hallo zusammen,

ich möchte alle Mailadressen aus einer Abfrage "quy_auswahl" über einen Button in die Adresszeile von Outlook übertragen.

Kann mir jemand einen Tipp geben?

Gruß
Dirk

Re: Mehrere Mail Empfänger in die Outlook Adresszeile

BeitragVerfasst: 14. Sep 2021, 15:10
von derArb
Hallo,
in Outlook wird beim Eintragen von mehreren Emailadressen als Trennzeichen der Strichpunkt verwendet (";").
Nutze das beim Zusammensetzen eines Strings in VBA durch Auslesen der Einträge Deiner Abfrage über ein Recordset
und übergib diesen String dann an OUTLOOK.

Folgendes Beispiel wird Dir helfen. Das Anpassen an Deine Problematik überlasse ich Deinem "Hirnschmalz".

ButtonCode in einem gebundenen Formular
Code: Alles auswählen
Private Sub btnSenden_Click()
Dim rs As DAO.Recordset, tmp As String
  Set rs = CurrentDb.OpenRecordset("SELECT * FROM qry_EmailSendeAuswahl WHERE EmailID_F =" & Me!emailID)
  If Not rs.EOF Then rs.MoveFirst
  While Not rs.EOF
    If Trim(Nz(rs("emailadresse"))) <> "" Then
        tmp = tmp & ";" & rs("emailadresse")
    End If
  rs.MoveNext
  Wend

  EmailVersenden Mid(tmp, 2), "", Nz(Me.Betreff, ""), Nz(Me!AnsprechText, "") & vbCrLf & vbCrLf & Nz(Me.NachrichtenText & vbCrLf & vbCrLf & _
                Nz(Me!GrussText, "") & vbCrLf & vbCrLf & Nz(Me!Sendername, "") & vbCrLf & Nz(Me!Senderstatus), ""), Me!emailID
  Me.Sendedatum = Now
  Me!gesendet = -1

End Sub


Code in einem allgemeinen Modul
Code: Alles auswählen
Option Compare Database
Option Explicit

Public Function EmailVersenden(email As String, ccEmail As String, emSubject As String, emBody As String, PK As Long)
' Bei Late Binding ==> Kein Verweis noetig!
Const olFolderInbox = 6
Const olFolderOutbox = 4
Const olMailItem = 0
Dim olApp       As Object
Dim olNamespace As Object
Dim objMailItem As Object
Dim objFolder   As Object
Dim rs As DAO.Recordset
On Error GoTo Fehler
  Set olApp = CreateObject("Outlook.Application")
  Set olNamespace = olApp.GetNamespace("MAPI")
  Set objFolder = olNamespace.GetDefaultFolder(olFolderInbox)
  Set objMailItem = objFolder.Items.Add(olMailItem)
  With objMailItem
      .To = email
      .cc = ccEmail
      .Subject = emSubject
      .Body = emBody
      Set rs = CurrentDb.OpenRecordset( _
          "SELECT doku_ID, DokuLink " & _
          "FROM tbl_Dateien " & _
          "WHERE emailID_f=" & PK)
      Do While Not rs.EOF
        If Dir(rs!DokuLink) <> "" Then
          .Attachments.Add "" & rs!DokuLink & ""
        End If
        rs.MoveNext
      Loop
      rs.Close: Set rs = Nothing
      'Application.Echo False
      .Display
  End With
  olApp.ActiveWindow
  'objMailItem.send
  'SendKeys "%s" 'für Acc2002 - 2003
  'Application.Echo True

  Set olApp = Nothing
  Set objMailItem = Nothing
  Exit Function
exit_Fehler:
Exit Function
Fehler:
MsgBox "Es ist ein Fehler aufgetreten. Schliessen Sie Outlook und versuchen Sie es bitte noch einmal."
Resume exit_Fehler

End Function