Email merge

sjobbels · 21 jan 2010

Hallo,

ik heb in mijn database een mailmerge gebouwd, die via een selectie in een formulier (zie bijlage) en een .dot file een normale mailmerge in word genereerd. Op basis van deze code wordt de mailmerge gestart:

Code:

Option Compare Database
Option Explicit
Private Const conTemplate As String = "CSMailMerge.dot"
Private Const conQuery As String = "qryMailmerge"
Private Const conTabel As String = "tmp"
Dim strSQl As String

Private Sub cmdClear_Click()

    strSQl = "UPDATE " & conQuery & vbCrLf
    strSQl = strSQl & "SET Mailmerge = Null " & vbCrLf
    strSQl = strSQl & "WHERE Mailmerge=True"
    DoCmd.RunSQL strSQl
    Me.Form.Requery

End Sub

Private Sub cmdSelect_Click()

    strSQl = "UPDATE " & conQuery & vbCrLf
    strSQl = strSQl & "SET Mailmerge = 1 " & vbCrLf
    strSQl = strSQl & "WHERE Mailmerge=False"
    DoCmd.RunSQL strSQl
    Me.Form.Requery

End Sub

Private Sub cmdGo_Click()
DoCmd.SetWarnings False
    strSQl = "SELECT NaamBedrijf, NaamLocatieDochter, CPAanhef, Aan, CPVoorletters, CPAchternaam, Adres, Postcode, Plaats, SalesManager, Telefoonnr, Mailmerge "
    strSQl = strSQl & "INTO tmp " & vbCrLf
    strSQl = strSQl & "FROM qryMailmerge " & vbCrLf
    strSQl = strSQl & "WHERE (Mailmerge = True) " & vbCrLf
    strSQl = strSQl & "ORDER BY NaamBedrijf;"
    DoCmd.RunSQL strSQl
    DoCmd.SetWarnings True
    
    Call Samenvoegen

End Sub

Public Sub Samenvoegen()
Dim rs As ADODB.Recordset

    Dim strPath As String
    Dim strDataSource As String
    
    Dim doc As Word.Document
    Dim wrdApp As Word.Application
                        
    On Error GoTo HandleErrors
    ' Delete the rtf file, if it already exists.
    strPath = FixPath(CurrentProject.Path)
    strDataSource = strPath & conQuery & ".doc"
        
    Set rs = New ADODB.Recordset
    rs.Open "SELECT * FROM tmp", CurrentProject.Connection, adOpenStatic, adLockPessimistic
    
    MsgBox "Aantal records: " & rs.RecordCount, vbOKOnly
    
    If rs.RecordCount = 0 Then Exit Sub
    ' Export the data to rtf format
    
    DoCmd.OutputTo acOutputTable, conTabel, acFormatRTF, strDataSource, False

    ' Start Word using mailmerge template
    Set wrdApp = New Word.Application
    Set doc = wrdApp.Documents.Add(strPath & conTemplate)
        
    ' Do the mail merge to a new document.
    With doc.Mailmerge
        .OpenDataSource Name:=strDataSource
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        If .State = wdMainAndDataSource Then
            .Execute
        End If
    End With
    
    ' Display the mail merge document
    wrdApp.Visible = True
    
ExitHere:
    Set doc = Nothing
    Set wrdApp = Nothing
    Exit Sub
    
HandleErrors:
    Select Case Err.Number
        Case 53         ' File not found
            Resume Next
        Case Else
            MsgBox Err.Number & ": " & Err.Description
            Resume ExitHere
    End Select
 End Sub

Private Function FixPath(strPath As String) As String
    If Right(strPath, 1) = "\" Then
        FixPath = strPath
    Else
        FixPath = strPath & "\"
    End If
End Function



Private Sub Form_Current()

    Me.txtsubMail.Requery
    If Me.txtsubMail.Value > 0 Then
        Me.cmdGo.Enabled = True
    Else
        Me.cmdGo.Enabled = False
    End If
    Me.Form.Recalc
''    Me.Form.Requery
    Me.Form.Refresh
    Me.Form.Repaint

End Sub

Private Sub chkMailmerge_AfterUpdate()

    If Me.Dirty Then
        Me.Dirty = False
    End If
    Me.txtsubMail.Requery
    If Me.txtsubMail.Value > 0 Then
        Me.cmdGo.Enabled = True
    Else
        Me.cmdGo.Enabled = False
    End If
''    Me.Form.Requery
    Me.Form.Refresh
    Me.Form.Repaint
    
End Sub

Nu is er de vraag gekomen om op basis van deze form of een nieuw form een E-mail merge te maken. Dus dat de geselecteerde emailadressen in de 'To' balk van outlook komen. Hoe krijg ik dit voorelkaar?

thanks

OctaFish · 21 jan 2010

je kunt dat zowiezo vanuit Word doen, door een sjabloon te maken die een Email merge doet i.p.v. een merge naar printer. Je moet dan wel het emailveld meegeven, maar dat lijkt mij niet zo'n probleem.
Anders kun je een HTML mail genereren, of een rapport mailen vanuit Access, dan heb je heel Word niet meer nodig.

sjobbels · 22 jan 2010

OctaFish zei:
je kunt dat zowiezo vanuit Word doen, door een sjabloon te maken die een Email merge doet i.p.v. een merge naar printer. Je moet dan wel het emailveld meegeven, maar dat lijkt mij niet zo'n probleem.
Anders kun je een HTML mail genereren, of een rapport mailen vanuit Access, dan heb je heel Word niet meer nodig.

Ok maar er hoeft in dit geval geen bijlage bij. Het is de bedoeling dat alleen de geselecteerde mailadressen in de to-balk komen.

OctaFish · 22 jan 2010

Wat wil je precies doen met de email? En wat moet er worden gemaild? En moeten alle adressen in één keer in één mail?

sjobbels · 22 jan 2010

Ik wil alleen dat de geselecteerde emailadressen in de to- balk komen te staan. Verder hoef er geen attachment of tekst bij te komen. Dit mag door de gebruiker zelf toegevoegd worden. De mail mag dus niet meteen verstuurd worden.

OctaFish · 22 jan 2010

Dus je wilt een string opbouwen met de emailadressen, gescheiden door een puntkomma?

sjobbels · 22 jan 2010

OctaFish zei:
Dus je wilt een string opbouwen met de emailadressen, gescheiden door een puntkomma?

Yes!

OctaFish · 22 jan 2010

Dan krijg je denk ik iets als dit:

strSQL = "SELECT NaamBedrijf, NaamLocatieDochter, CPAanhef, Aan, CPVoorletters, CPAchternaam, Email, SalesManager, Telefoonnr, Mailmerge "

Code:

With CurrentDb.OpenRecordset("SELECT * FROM tmp")
     .MoveFirst
     Do While Not .EOF
         If Not .Fields("Email").Value = "" Then
             stEmail = stEmail & .Fields("Email").Value & ";"
         End If
         .MoveNext
     Loop
 End With

Do While Right(stEmail, 1) = ";"
    stEmail = Left(stEmail, Len(stEmail) - 1)
Loop

De rest van de samenvoeging zal denk ik wel lukken?

sjobbels · 22 jan 2010

thanks, ik ga het zo even proberen.

Ik krijg nu een runtime error 3265 bij: If Not .Fields("Email").Value = "" Then

sjobbels · 1 feb 2010

Octafish,

Ik heb nog vanalles geprobeerd, heb ook nog een aantal andere voorbeelden gevonden, maar deze werken alleen met een listbox.

Kun jij aan onderstaande codering zien waar het mis gaat??

Code:

Option Compare Database
Option Explicit
Private Const conquery As String = "qryEmailgroep"
Private Const conTabel As String = "tmp"
Dim strSQL As String

Private Sub cmdClear_Click()

    strSQL = "UPDATE " & conquery & vbCrLf
    strSQL = strSQL & "SET Emailgroep = Null " & vbCrLf
    strSQL = strSQL & "WHERE Emailgroep=True"
    DoCmd.RunSQL strSQL
    Me.Form.Requery

End Sub

Private Sub cmdSelect_Click()

    strSQL = "UPDATE " & conquery & vbCrLf
    strSQL = strSQL & "SET Emailgroep = 1 " & vbCrLf
    strSQL = strSQL & "WHERE Emailgroep=False"
    DoCmd.RunSQL strSQL
    Me.Form.Requery

End Sub


Private Sub cmdGo_Click()
DoCmd.SetWarnings False
    strSQL = "SELECT NaamBedrijf, NaamLocatieDochter, CPAanhef, Aan, CPVoorletters, CPAchternaam, SalesManager,Email, Emailgroep "
    strSQL = strSQL & "INTO tmp " & vbCrLf
    strSQL = strSQL & "FROM qryEmailgroep " & vbCrLf
    strSQL = strSQL & "WHERE (Emailgroep = True) " & vbCrLf
    strSQL = strSQL & "ORDER BY NaamBedrijf;"
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True
    
    Call Samenvoegen

End Sub


Public Sub Samenvoegen()
Dim rs As ADODB.Recordset
Dim r As Recordset
Dim Email As String
Dim stLinkCriteria As String
Dim stSubject As String
Dim Message As String

                         
             
    Set rs = New ADODB.Recordset
    rs.Open "SELECT * FROM tmp", CurrentProject.Connection, adOpenStatic, adLockPessimistic
    
    MsgBox "Aantal records: " & rs.RecordCount, vbOKOnly
    
    If rs.RecordCount = 0 Then Exit Sub
    With CurrentDb.OpenRecordset("SELECT * FROM tmp")
    .MoveFirst
Do While Not r.EOF
    stLinkCriteria = Email & r(2) & ";"
    stSubject = "Test"
    r.MoveNext
    Loop
        r.Close
    End With
        DoCmd.SendObject acSendNoObject, , , stLinkCriteria, , , stSubject
    
End Sub



Private Sub Form_Current()

    Me.txtsubMail.Requery
    If Me.txtsubMail.Value > 0 Then
        Me.cmdGo.Enabled = True
    Else
        Me.cmdGo.Enabled = False
    End If
    Me.Form.Recalc
''    Me.Form.Requery
    Me.Form.Refresh
    Me.Form.Repaint

End Sub

Private Sub chkEmailgroep_AfterUpdate()

    If Me.Dirty Then
        Me.Dirty = False
    End If
    Me.txtsubMail.Requery
    If Me.txtsubMail.Value > 0 Then
        Me.cmdGo.Enabled = True
    Else
        Me.cmdGo.Enabled = False
    End If
''    Me.Form.Requery
    Me.Form.Refresh
    Me.Form.Repaint
    
End Sub

Ik hoop dat je me verder kunt helpen
Bedankt alvast

OctaFish · 1 feb 2010

Ik zie vooral problemen met de hoofdroutine; ik neem aan dat daar ook de foutmelding vandaan komt?
Probeer 'm eens zo:

Code:

Public Sub Samenvoegen()
Dim rs As Recordset
Dim Email As String
Dim stLinkCriteria As String
Dim stSubject As String
Dim Message As String
    
    With CurrentDb.OpenRecordset("SELECT * FROM tmp")
        If .RecordCount > 0 Then
            MsgBox "Aantal records: " & rs.RecordCount, vbOKOnly
            .MoveFirst
            Do While Not .EOF
                stLinkCriteria = Email & .Fields(2).Value & ";"
                stSubject = "Test"
                .MoveNext
            Loop
        End If
        .Close
    End With
    DoCmd.SendObject acSendNoObject, , , stLinkCriteria, , , stSubject

End Sub

Zoals je ziet, heb ik nogal wat weggehaald:

Set rs = New ADODB.Recordset
Hier open je de tabel...
rs.Open "SELECT * FROM tmp", CurrentProject.Connection, adOpenStatic, adLockPessimistic

En hier nog een keer....
With CurrentDb.OpenRecordset("SELECT * FROM tmp")
Maar de tabel is al open!
.MoveFirst
Waar komt de r vandaan? Je hebt geen SET gebruikt om hem toe te wijzen...
Do While Not r.EOF
stLinkCriteria = Email & r(2) & ";"
stSubject = "Test"
r.MoveNext
Loop
r.Close
End With

Kortom: niet te moeilijk denken!

sjobbels · 1 feb 2010

thanks voor de snelle reactie.:thumb:
zo ziet het er idd ook een stuk overzichtelijker uit. En het begint me nu ook allemaal wat duidelijker te worden.

Als ik de code uitvoer loop ik tegen 2 problemen aan:
1) bij de msgbox krijg ik de volgende foutmelding--> Fout 91 tijdens uitvoering: Objectvariabele of blokvariabele With is niet ingesteld.
2) als ik de msgbox verwijder (liever niet) dan werkt de uitvoering naar outlook wel, maar hij pakt iedere keer maar 1 emailadres ook al heb ik er meerdere aangevinkt.

ReneDirks · 1 feb 2010

Nou Michel, het is wel grappig dat we zo'n beetje op dezelfde golflengte zitten

En ik weet dat je maar even snel de code opgeschoond hebt, want jij zou dit zelf volgens mij nooit zo oplossen:

OctaFish zei:
Do While Not .EOF
stLinkCriteria = Email & .Fields(2).Value & ";"
stSubject = "Test"
.MoveNext
Loop
End Sub[/CODE]

Betekent dat je voor ieder record het subject van de mail opnieuw gaat instellen.

OctaFish · 1 feb 2010

@Ren'e: Ik heb me inderdaad gefocused op de oplossing van het probleem, niet de Subject code

De foutmelding kan worden veroorzaakt doordat de bibliotheken niet helemaal goed geladen zijn: in het vba scherm: <Extra>, <Verwijzingen>. Waarschijnlijk heb je een ADO 2.# bibliotheek en een DAO 3.6 bibliotheek geladen. Controleer of de DAO bibliotheek als laatste wordt geladen, dan zou het probleem al weg kunnen zijn.
Het probleem van de enkele mail is ook wel logisch; de SendObject wordt nu één keer uitgevoerd. Je zou hem denk ik vóór de Movenext moeten zetten.
Effe testen dus! Ik zie zo snel ook niet wat-ie allemaal moet ophalen...

sjobbels · 2 feb 2010

Hoi Octafish en Rene,

Het lukt nog steeds niet:

Code:

Public Sub Samenvoegen()
Dim rs As Recordset
Dim Email As String
Dim stLinkCriteria As String
Dim stSubject As String
Dim Message As String
    
    With CurrentDb.OpenRecordset("SELECT * FROM tmp")
        If .RecordCount > 0 Then
            .MoveFirst
            Do While Not .EOF
                stLinkCriteria = Email & .Fields(7).Value & ";"
                stSubject = "Test"
                DoCmd.SendObject acSendNoObject, , , stLinkCriteria, , , stSubject
                .MoveNext
            Loop
        End If
        .Close
    End With
End Sub

Ik krijg nog steeds alleen het eerste emailadres in outlook te zien en niet de andere aangevinkte emails......

OctaFish · 2 feb 2010

Ik ben een beetje verward door deze regel:

stLinkCriteria = Email & .Fields(7).Value & ";"

En dan met name door: & ";"
Ik vermoed, dat je één string wilt maken voor de emailadressen, en dat je dus ook maar één verzendactie wilt uitvoeren. Als dat zo is, gaat dit niet werken, omdat je bij elk record het criterium vervangt door een volgend record, en dus uiteindelijk maar één mailadres (het laatste) overhoudt.
Je moet het criterium uitbreiden, niet vervangen. Dus:

stLinkCriteria = stLinkCriteria & Email & .Fields(7).Value & ";"
Als dit de bedoeling is, kan de Docmd.Sendobject ook weer uit de loop, anders blijft-ie toch mailen.... Wat dacht ik toch zou moeten gebeuren, maar dan voor alle aparte records. Maar dit terzijde...

ReneDirks · 2 feb 2010

Maar 'Email' krijgt dan weer nergens een waarde toegewezen en zal dus een lege string zijn. Waarschijnlijk is de code samengevoegd uit meerdere stukjes en is dat een overblijfsel.

OctaFish · 2 feb 2010

Daar vanuit gaande, zou het zou kunnen zijn?

stLinkCriteria = stLinkCriteria & .Fields(7).Value & ";"

sjobbels · 3 feb 2010

helaas... het werkt niet. Hij pakt nog steeds maar 1 emailadres. Mijn database is te groot (en te vertrouwelijk) om hier te plaatsen.

Ik vermoed, dat je één string wilt maken voor de emailadressen, en dat je dus ook maar één verzendactie wilt uitvoeren

Ja idd

Ik heb wel een voorbeeld gevonden adh van een listbox, maar dit wil ik liever niet, omdat er aan mijn formulier een zoekfunctie gekoppeld zit (zie plaatje eerste post).
Misschien hebben jullie hier iets aan?

OctaFish · 3 feb 2010

Kun je wel controleren of de emailadressen in één variabele worden gezet? Bijvoorbeeld met een Msgbox?

Email merge

Gebruiker

Bijlagen

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Gebruiker

Gebruiker

Verenigingslid

Gebruiker

Terugkerende gebruiker

Verenigingslid

Gebruiker

Verenigingslid

Terugkerende gebruiker

Verenigingslid

Gebruiker

Bijlagen

Verenigingslid

Wij waarderen jouw privacy