email kan dit zo worden aangepast dat hij meerdere emails aanmaakt en verzend.

[dinoshop]

deze code werkt, nu de vraag ik werk in de formulier met een filter dus me.filter.
kan deze script zo worden aangepast dat hij ook de filter gebruikt om adressen in de mail aan te maken bv in cc .

Private Sub Mailpp_DblClick(Cancel As Integer)
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim eMail As String
Dim sVerzonden As String
Dim iAantal As Integer, I As Integer
Me.eMail = ""


Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)


On Error GoTo Mailpp_Err
sVerzonden = Me.eMail

Me.eMail = DLookup("email", "tblpersoneel", "PersoneelNR=" & [Werknemer]) _

      DoCmd.SendObject acSendReport, "RptPlanning", acFormatPDF, Me.eMail, , , Me.Werknemer, , True
      
     
    MsgBox "Er is een mail gestuurd naar " & sVerzonden & "."
    
   If Len(Verzonden) = 0 Then
Verzonden.Value = False
Else
Verzonden.Value = True

    Exit Sub
Mailpp_Err:
    MsgBox Error$
End If
End Sub

 

[OctaFish]

Je kan er toch een cc adres bijzetten in de SendObject regel? Overigens vind ik het een erg omslachtige procedure, die volgens mij veel simpeler moet kunnen. Al was het maar omdat je een Outlook sessie opent en niet gebruikt.

 

[dinoshop]

klopt geen probleem
maar waar hoe zet ik vba zo dat hij echt kijkt naar de mensen die in filter zitten
zodat ik geen query er voor aanmaken .
dus direct van uit filter zoeken naar email adres en dan verzenden

 

[dinoshop]

octa

jij geeft aan dat dit anders kan, vertel .
of beter laat dit eens zien ben erg benieuwd leer graag bij.

 

[dinoshop]

krijg een fout code 3131 war beteknd dit

ik gebruik nu deze code om emal adressen te filteren en een mail te maken .
maar op het deel wat normaal wel werkt geeft hij nu code 3131
dat is het dikke gedeelte wat is er fout

Private Sub Test_Click()
Dim strSQL As String, strSQL_Rapport As String
Dim sTabel As String, sRapport As String, iAantal As String
Dim X As Integer
Dim strwhere As String

strSQL = "SELECT * FROM qryPlanning"
sRapport = "rptPlanning"

DoCmd.Echo False, "Bezig met openen van recordset."
With CurrentDb.OpenRecordset(strSQL)
    
    .MoveLast
    .MoveFirst
    iAantal = .RecordCount
    If iAantal > 0 Then
        For X = 1 To iAantal
        strwhere = strwhere & "([Werknemer] = " & Me.CboWerknemer & ").Value"
            DoCmd.Echo False, "Samenvoegen van Record " & X & " van " & iAantal & " records..."
            DoCmd.OpenReport sRapport, acViewDesign, , , acHidden
            sTabel = Reports(sRapport).RecordSource
            If InStr(1, UCase(sTabel), "WHERE") > 0 Then
                strSQL_Rapport = Left(sTabel, InStr(1, sTabel, "WHERE ") - 1)
            Else
                If InStr(1, UCase(sTabel), "SELECT") = 0 Then
                    If InStr(1, sTabel, " ") > 0 And InStr(1, sTabel, "[") = 0 Then
                        sTabel = "[" & sTabel & "]"
                    End If
                    strSQL_Rapport = "SELECT * FROM " & sTabel & " "
                Else
                    strSQL_Rapport = sTabel
                End If
            End If
            
            Do Until Right(strSQL_Rapport, 1) <> ";"
                strSQL = Left(strSQL_Rapport, Len(strSQL_Rapport) - 1)
            Loop
            
            
            strSQL_Rapport = strSQL_Rapport & Me.Filter
            Reports(sRapport).RecordSource = strSQL_Rapport
            DoCmd.Close acReport, sRapport, acSaveYes
            Me.Email = DLookup("email", "tblpersoneel", "PersoneelNR=" & [Werknemer])
           [B] DoCmd.SendObject acSendReport, "RptPlanning", acFormatPDF, Me.Email, , , , Me.Werknemer, True[/B]            .MoveNext
        Next
    End If
    .Close
End With
End Sub

 

[dinoshop]

krijg fout code 3131 wat betekend dit

ik gebruik deze code om mail adressen te verzamelen en dan een rapport te verzenden.
nu geeft die fout op een regel deze wordt geel aangegeven, wat is er fout mee.

Private Sub Test_Click()
Dim strSQL As String, strSQL_Rapport As String
Dim sTabel As String, sRapport As String, iAantal As String
Dim X As Integer
Dim strwhere As String

strSQL = "SELECT * FROM qryPlanning"
sRapport = "rptPlanning"

DoCmd.Echo False, "Bezig met openen van recordset."
With CurrentDb.OpenRecordset(strSQL)
    
    .MoveLast
    .MoveFirst
    iAantal = .RecordCount
    If iAantal > 0 Then
        For X = 1 To iAantal
        strwhere = strwhere & "([Werknemer] = " & Me.CboWerknemer & ").Value"
            DoCmd.Echo False, "Samenvoegen van Record " & X & " van " & iAantal & " records..."
            DoCmd.OpenReport sRapport, acViewDesign, , , acHidden
            sTabel = Reports(sRapport).RecordSource
            If InStr(1, UCase(sTabel), "WHERE") > 0 Then
                strSQL_Rapport = Left(sTabel, InStr(1, sTabel, "WHERE ") - 1)
            Else
                If InStr(1, UCase(sTabel), "SELECT") = 0 Then
                    If InStr(1, sTabel, " ") > 0 And InStr(1, sTabel, "[") = 0 Then
                        sTabel = "[" & sTabel & "]"
                    End If
                    strSQL_Rapport = "SELECT * FROM " & sTabel & " "
                Else
                    strSQL_Rapport = sTabel
                End If
            End If
            
            Do Until Right(strSQL_Rapport, 1) <> ";"
                strSQL = Left(strSQL_Rapport, Len(strSQL_Rapport) - 1)
            Loop
            
            
            strSQL_Rapport = strSQL_Rapport & Me.Filter
            Reports(sRapport).RecordSource = strSQL_Rapport
            DoCmd.Close acReport, sRapport, acSaveYes
            Me.Email = DLookup("email", "tblpersoneel", "PersoneelNR=" & [Werknemer])
            DoCmd.SendObject acSendReport, "RptPlanning", acFormatPDF, Me.Email, , , , Me.Werknemer, True
            .MoveNext
        Next
    End If
    .Close
End With
End Sub