• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

e-mail versturen vanuit Excel

Status
Niet open voor verdere reacties.
E

Egbert12345

Gebruiker
Lid geworden
13 dec 2010
Berichten
496
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
 
Begin eens met je code met terugwerkende kracht op te maken met de CODE knop (knop #), want hier is zo geen doorkomen aan :).
 
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
 
Egbert12345 zei:
excuses hiervoor, zal ik doen.
Klik om te vergroten...

Uuuhm, heb je dus niet gedaan.

Code: 
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
 
Inderdaad. Plus dat de inspringpunten fatsoenlijk op hun plek blijven.

Edit:
Kennelijk had ik eerst koffie nodig voor ik zag wat je bedoelde :eek:;)
 
Laatst bewerkt:
:d

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

Met een andere code
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.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan