Vanuit Excel massa-mailing naar de leden

[Gert Bouwmeeste]

Goedemorgen,

Dit is een vervolg op het gesloten topic https://www.helpmij.nl/forum/showth...Outlook-met-VBA-berichten-aanmaken-en-opslaan
Ik kom er niet uit en heb een uitgebreider voorbeeldbestand gemaakt met "mijn eigen macro". Die het dus niet helemaal goed doet.

Het echte bestand omvat een 220 leden, die komen met een CSV-download uit het softwarepakket SportLink.
De leden moeten individueel een mailtje krijgen, bv met een nieuwsbrief als bijlage (facultatief). In het voorbeeldbestand 4 dummy-leden.

Ik heb een macro gemaakt:

Sub MailIndividueel()

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' Instellen wat een NweRegel is
        NweRegel = Chr$(12) & Chr$(13)
    
    'Tel het aantal mailtjes dat verzonden moet worden
        [B26].Formula = "=COUNTA('Download Sportlink'!C[10])-1"
        [B26].HorizontalAlignment = xlLeft
        AantalMails = [B26].Value

    
    'Selecteer het tabblad met de download uit Sportlink en ga naar de regel van het eerste lid
        Sheets("Download Sportlink").Select
        Range("A2").Select
    
    For verwerken = 1 To AantalMails 
        
        ' Haal de relatiecode op vanuit de download van SportLink en zet die in het sjabloon
            Relatiecode = ActiveCell.Value
            Sheets("Sjabloon").Range("B28").Value = Relatiecode
        
        ' Lees het mailadres uit in kolom "L"
            Mailadres = Sheets("Sjabloon").[B9].Value
        
        ' Stel het mailtje op
            With OutMail
                .To = Mailadres
                .CC = ""
                .BCC = ""
                .Subject = Sheets("Sjabloon").[B11].Value & " " & Relatiecode
                .Body = Sheets("Sjabloon").[B13].Value & NweRegel & NweRegel & Sheets("Sjabloon").[B15].Value & " " & NweRegel & NweRegel & Sheets("Sjabloon").[B17].Value & NweRegel & NweRegel & Sheets("Sjabloon").[B18].Value
            
            'Eventueel een bijlage bijvoegen
            ' .Attachments.Add [B20].Value & [B21].Value
            
            [COLOR="#FF0000"][B]' Laat de aangemaakte mail op het scherm zien
             .Display
            
            'Verzend de mail meteen
            '.Send
            
            'Sluit het aangemaakte mailtje en sla m op in Concepten
            .Close olSave
           [/B][/COLOR]
        End With
            
        ' Leeg maken
            Mailadres = ""
            Relatiecode = ""
            
            With OutMail
                    .To = ""
                    .CC = ""
                    .BCC = ""
                    .Subject = ""
                    .Body = ""
            End With
                
        ' Ga weer naar het tabblad met de download uit Sportlink en ga één regel naar beneden
            Sheets("Download Sportlink").Select
            ActiveCell.Offset(1, 0).Range("A1").Select
            
    Next
    
    'Einde = klaar
    
End Sub

De macro op zich draait wel. Maar ...

- Als ik de optie ".Display" gebruik dan wordt er aan het einde van de rit maar één conceptmailtje aangemaakt met de gegevens van het laatste lid. Bij ieder nieuw lid wordt de concept-mail van het vorige lid overschreven.

- Als ik de optie ".Send" gebruik dan loopt de macro vast bij het aanmaken van het mailtje voor het tweede lid met de melding "Het item is verplaatste of verwijderd", zie afbeelding.

Iemand een idee hoe dit goed te krijgen?

 

[edmoor]

Haal die Set OutMail opdracht bovenin weg en plaats hem hier:

        [COLOR="#008000"]' Stel het mailtje op[/COLOR]
            Set OutMail = OutApp.CreateItem(0)
            With OutMail

Dat kan je dan ook wijzigen in:

        [COLOR="#008000"]' Stel het mailtje op[/COLOR]
            With OutApp.CreateItem(0)

Het "leeg maken" gedeelte kan helemaal weg.

 

[Gert Bouwmeeste]

Yes ..... :thumb::thumb::thumb:

Dat werkt! Hartstikke bedankt @Edmoor!