e-mail versturen vanuit Excel

[Egbert12345]

Beste forummers, vorig jaar heeft Edmoor mij perfect geholpen met het maken van een macro in VBA waarbij ik gepersonaliseerde e-mails kan versturen. Voorheen werkte ik met Windows Live Mail, maar inmiddels met Outlook 2016. Ik kan mij herinneren dat Edmoor in eerste instantie uitging van Outlook, maar dat later heeft aangepast naar Windows Live Mail. Nu kan ik dat oorspronkelijke bericht niet meer terugvinden en daarom assistentie gevraagd. Onderstaand de code die ik gebruikte (let s.v.p. niet op de verwijzingen naar de werkbladen). Kunnen jullie aangeven wat ik moet aanpassen zodat de macro werkt met Outlook 2016?
m.vr.gr Egbert


Sub CDO_Mail_Small_Text_LEDEN()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant

Application.ScreenUpdating = False
Sheets("verzendblad LEDEN").Select
eindebereik = Sheets("verzendblad LEDEN").Range("W25") ' totaal aantal records bepalen

' regels geel kleuren en controlewaarde opvoeren
Sheets("e-mail LEDEN").Select
Rows("2:" & eindebereik & "").Interior.Color = 65535
Range("AK2") = "1"
Range("AK2").Copy: Range("AK3:AK" & eindebereik & "").Select: ActiveSheet.Paste
Range("A1").Select: Application.CutCopyMode = False

Sheets("verzendblad LEDEN").Select
For A = 2 To eindebereik
On Error GoTo einde_macro

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.kpnmail.nl"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

Sheets("e-mail LEDEN").Rows(A).Copy
Range("A34").Select
Selection.PasteSpecial Paste:=xlPasteValues

aan_email = Sheets("verzendblad LEDEN").Range("P34"):
onderwerp = Sheets("verzendblad LEDEN").Range("H20"):
afzender_email = Sheets("verzendblad LEDEN").Range("C21"):
BCC_email = Sheets("verzendblad LEDEN").Range("C20")

aanhef = Sheets("verzendblad LEDEN").Range("B1")
omschrijving1 = Sheets("verzendblad LEDEN").Range("B3"):
omschrijving2 = Sheets("verzendblad LEDEN").Range("B4"):
omschrijving3 = Sheets("verzendblad LEDEN").Range("B5"):
omschrijving4 = Sheets("verzendblad LEDEN").Range("B6"):
omschrijving5 = Sheets("verzendblad LEDEN").Range("B7")
omschrijving6 = Sheets("verzendblad LEDEN").Range("B9"):
omschrijving7 = Sheets("verzendblad LEDEN").Range("B10"):
omschrijving8 = Sheets("verzendblad LEDEN").Range("B12"):
omschrijving9 = Sheets("verzendblad LEDEN").Range("B13"):
omschrijving10 = Sheets("verzendblad LEDEN").Range("B14")

strbody = aanhef & vbNewLine & vbNewLine & _
omschrijving1 & vbNewLine & _
omschrijving2 & vbNewLine & _
omschrijving3 & vbNewLine & _
omschrijving4 & vbNewLine & _
omschrijving5 & vbNewLine & vbNewLine & _
omschrijving6 & vbNewLine & _
omschrijving7 & vbNewLine & vbNewLine & _
omschrijving8 & vbNewLine & _
omschrijving9 & vbNewLine & _
omschrijving10

With iMsg
Set .Configuration = iConf
.To = aan_email
' .CC = ""
.BCC = BCC_email
.From = afzender_email
.Subject = onderwerp
.TextBody = strbody
.Send
End With

Sheets("e-mail LEDEN").Rows(A).Interior.Pattern = xlNone
Sheets("e-mail LEDEN").Cells(A, 37) = 0

einde_macro:

Next

Application.CutCopyMode = False
If Sheets("verzendblad LEDEN").Range("W29") > 0 Then MsgBox "Er zijn records waarbij de e-mail niet is verstuurd omdat er een fout in het e-mailadres zit. De betreffende regel is geel gearceerd.": Sheets("e-mail LEDEN").Select: Range("A2").Select: End

Application.ScreenUpdating = True
Sheets("verzendblad LEDEN").Select

End Sub

 

[OctaFish]

Begin eens met je code met terugwerkende kracht op te maken met de CODE knop (knop #), want hier is zo geen doorkomen aan .

 

[Egbert12345]

excuses hiervoor, zal ik doen.

 

[Egbert12345]

Hoi, ik heb er nu de nodige ballast uitgehaald. Kan je hier iets mee?
gr Egbert


Sub CDO_Mail_Small_Text_LEDEN()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.kpnmail.nl"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

aan_email = Sheets("verzendblad LEDEN").Range("P34"):
onderwerp = Sheets("verzendblad LEDEN").Range("H20"):
afzender_email = Sheets("verzendblad LEDEN").Range("C21"):
BCC_email = Sheets("verzendblad LEDEN").Range("C20")
aanhef = Sheets("verzendblad LEDEN").Range("B1")
omschrijving1 = Sheets("verzendblad LEDEN").Range("B3"):

strbody = aanhef & vbNewLine & vbNewLine & _
omschrijving1 & vbNewLine & _

With iMsg
Set .Configuration = iConf
.To = aan_email
.CC = ""
.BCC = BCC_email
.From = afzender_email
.Subject = onderwerp
.TextBody = strbody
.Send
End With

Next

 

[edmoor]

excuses hiervoor, zal ik doen.

Uuuhm, heb je dus niet gedaan.

Sub OutlookMail()

    With Sheets("verzendblad LEDEN")
        aan_email = .Range("P34")
        onderwerp = .Range("H20")
        BCC_email = .Range("C20")
        aanhef = .Range("B1")
        omschrijving1 = .Range("B3")
    End With

    strbody = aanhef & vbNewLine & vbNewLine & _
              omschrijving1 & vbNewLine

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .to = aan_email
        .CC = ""
        .BCC = BCC_email
        .Subject = onderwerp
        .Body = strbody
        .Send
    End With
End Sub

 

[VenA]

Uuuhm, heb je dus niet gedaan.

Wordt de code ook gelijk een stuk korter van. Slimme dingen wel die codetags:d

 

[edmoor]

Inderdaad. Plus dat de inspringpunten fatsoenlijk op hun plek blijven.

Edit:
Kennelijk had ik eerst koffie nodig voor ik zag wat je bedoelde

 

[VenA]

:d

Ik ben wel benieuwd naar het bestand. Het zweeft allemaal nogal.

Met een andere code

Sub VenA()
  With Sheets("verzendblad LEDEN")
    ar = Array(.[P34].Value, .[C20].Value, .[H20].Value, .[B1] & vbNewLine & vbNewLine & .[H20] & vbNewLine, .[C21].Value)
  End With
  
  With CreateObject("Outlook.Application").CreateItem(0)
    .to = ar(0)
    .BCC = ar(1)
    .Subject = ar(2)
    .Body = ar(3)
    .SentOnBehalfOfName = ar(4)
    .display 'Send
  End With
End Sub

Alleen werkt bij mij .SentOnBehalfOfName niet. Het wordt verzonden via mijn standaard account.

 

[eriksmit1964]

Dag,
Zoek eens op Ron de Bruin excel outlook. Hij heeft een artikel geschreven over dit onderwerp (engelstalig). Er staat een voorbeeld.

https://msdn.microsoft.com/en-us/library/ff458119(office.11).aspx

Grt,
Erik

 

[Egbert12345]

Mijn dank allen, hiermee gaat het wel lukken.
m.vr.gr. Egbert