Mailen naar lijst

Status
Niet open voor verdere reacties.
C

chiellebeest

Gebruiker
Lid geworden
5 jan 2010
Berichten
100
Hallo,

ik gebruik onderstaande code om vanuit Access een mail te versturen met een pdf in de bijlage. Dit gaat dit goed, alleen komt het nog wel eens voor dat ik een emailadres moet wijzigen, ik open dan de code en pas dit aan bij strto.

Ik heb een tabel toegevoegd met alle (55) emailadressen, mocht er wijziging zijn, kan ik dat eenvoudig in deze lijst aanpassen. Ik wil dus al deze emailadressen toevoegen aan de strto (BCC).

Mijn vraag: Is het mogelijk om bij de strto te verwijzen naar de tabel?
Ik heb al wat geprobeerd, maar is nog niet gelukt.

Code: 
Private Sub Knop10_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strto As String
    Dim strbody As String
    Dim SigString As String
    Dim mailaccount As Object
    Dim objOutlook As Object
    Dim objoutlookaccount As Object
    
     
  strbody = "<BODY style=font-size:11pt;font-family:Calibri>Hallo allemaal," & "<br><br>" & _
            "hierbij aanstellingen van de scheidsrechters voor a.s. weekend." & "<br>" & _
            "Mocht er bij jouw wedstrijd/ team geen scheidsrechter aangesteld zijn, dien je zelf zorg te dragen voor een scheidsrechter.</BODY>"
            
  SigString = Environ("appdata") & "Roaming\Microsoft\Signatures\Scheidsrechters.htm"
  
  strto = " email adressen "
  
    'Change only Mysig.htm to the name of your signature
    'de map signatures heet soms handtekeningen
    SigString = Environ("appdata") & _
                "Roaming\Microsoft\Handtekeningen\Scheidsrechters.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    
    
                Set objOutlook = CreateObject("Outlook.Application")
                Set objoutlookaccount = GetOutlookAccount(objOutlook, "scheidsrechters")
                With objOutlook.CreateItem(0)
                Set .sendusingaccount = objoutlookaccount
                .display
                .BCC = strto
                .Subject = "Aanstellingen"
                .HTMLbody = strbody & .HTMLbody
                .display  'Or use send.
                .Attachments.Add "\\Database\Aanstellingen.pdf"
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        
cleanup:
    Set OutApp = Nothing
End Sub
 
Je zou dan een string op kunnen bouwen door de adressen in de tabel met behulp van een recordset langs te lopen. Zelf maakte ik eens dit (relevant fragment van volledige code):
Code: 
Set rs = CurrentDb.OpenRecordset("Mailing")

MailCount = 0
While Not rs.EOF
    If MailCount > 0 Then strBCC = strBCC & ";"
    
    strBCC = strBCC & rs![E-mailadres]
    
    MailCount = MailCount + 1
    rs.MoveNext
Wend

Mijn strBCC is dus vergelijkbaar met jouw strto.
 
@xps: dit
Code: 
While Not rs.EOF
  If MailCount > 0 Then strBCC = strBCC & ";"
  strBCC = strBCC & rs![E-mailadres]
  MailCount = MailCount + 1
  rs.MoveNext
Wend
Kan een stuk korter:
Code: 
While Not rs.EOF
  strBCC = strBCC & IIf(strBCC = "", "", ";") & rs![E-mailadres]
  rs.MoveNext
Wend
 
@ TS:
Jouw procedure komt er dan zo uit te zien:

Code: 
Private Sub Knop10_Click()Dim objOutlook As Object
Dim objOutlookAccount As Object
Dim strTo As String, strBody As String, SigString As String
Dim MailAccount As Object
Dim rs As DAO.Recordset

    strBody = "<BODY style=font-size:11pt;font-family:Calibri>Hallo allemaal," & "<br><br>" & _
            "Hierbij aanstellingen van de scheidsrechters voor a.s. weekend." & "<br>" & _
            "Mocht er bij jouw wedstrijd/team geen scheidsrechter aangesteld zijn, " & _
            "dien je zelf zorg te dragen voor een scheidsrechter.</BODY>"
        
    On Error Resume Next
    'Verander SigString naar "Signatures" als de map "Handtekeningen" heet
    SigString = Environ("appData") & "Roaming\Microsoft\Handtekeningen\Scheidsrechters.htm"
    'SigString = Environ("appData") & "Roaming\Microsoft\Signatures\Scheidsrechters.htm"
    On Error GoTo 0

    Set rs = CurrentDb.OpenRecordset("Mailing")
    rs.MoveFirst
    While Not rs.EOF
      strTo = strTo & IIf(strTo = "", "", ";") & rs!EmailAdres
      rs.MoveNext
    Wend
    
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next
    Set objOutlook = CreateObject("Outlook.Application")
    Set objOutlookAccount = GetOutlookAccount(objOutlook, "scheidsrechters")
    With objOutlook.CreateItem(0)
        Set .SenduUsingAccount = objOutlookAccount
        .BCC = strTo
        .Subject = "Aanstellingen"
        .HTMLbody = strBody & .HTMLbody
        .Display
        'Or use Send.
        .Attachments.Add "\\Database\Aanstellingen.pdf"
    End With

End Sub

Wel even de juiste namen aanpassen van je tabel en veld uiteraard. En vermijd overtollige/overbodige code, zoals "Set OutApp = Nothing".
 
Allen dank voor jullie reacties, het is gelukt! Ik heb gelijk een 2e lijst aangemaakt om een ander rapport te kunnen versturen!! :d
 
Mag je de vraag nog op <opgelost> zetten!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan