VBA mailen met andere afzender

[RenevdH]

Beste Forumleden,

Ik heb al een aantal posts gevonden die over dit onderwerp gaan, maar het probleem waar ik tegenaan loop heb ik daar niet tussen gevonden.

Wat is het probleem: ik heb in Excel een bestand van waaruit dagelijks een aantal mails verzonden moeten worden. Deze mails moeten gebruik maken van een andere afzender dan de standaard mailaccount. Met onderstaande code lukt dat ook prima, zolang het maar 1 mail is. Is er door de selectie in het Excelbestand echter meer dan 1 mail te versturen, dan krijg ik de foutmelding: "Fout 9 tijdens de uitvoering: Objectvariable of blokvariabele With is niet ingesteld". Ik heb geen idee wat er niet goed is en waarom het wel werkt als er maar 1 mail verstuurd moet worden. Iemand die het wel ziet en weet wat de oplossing is?

De code is:

Sub Opvolging()

Dim objOutlook As Object
Dim objMail As Object
Dim strAan As String
Dim strOnderwerp As String
Dim strbody As String
Dim strAttachment As String
Dim oAccount As Object
Dim Recipients As String
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim address As Range, rngCell As Range
Dim Lr As Integer
Dim i As Integer
Dim OpvDate As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set ws = Sheets("Op te volgen")
Set ws1 = Sheets("MailMerge")
Lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lr
Set OpvDate = ws.Range("A" & i)
Set WachtenJa = ws.Range("H" & i)
checking = (Format(OpvDate, "mmm-dd") = Format(Date, "mmm-dd")) And WachtenJa = "Ja"
ws.Cells(i, 16).Value = checking
If ws.Cells(i, 16).Value = True Then
NaamVerkoper = ws.Cells(i, 13)
NaamKlant = ws.Cells(i, 11)
Offertenummer = ws.Cells(i, 9)
SoortContract = ws.Cells(i, 4)
Recipients = ws.Range("N" & i).Value
strAan = Recipients

strOnderwerp = "Opvolging aanvraag " & Offertenummer & " t.n.v. " & NaamKlant
strbody = "<br>" & _
"Beste " & NaamVerkoper & "<br>" & _
"Dit is het bericht <br>"

For Each oAccount In objOutlook.Session.Accounts
If oAccount.SmtpAddress = "opvolging@test.nl" Then
Exit For
End If
Set oAccount = Nothing
Next
If Not oAccount Is Nothing Then
With objMail
.To = strAan
.CC = strCC
.Subject = strOnderwerp
.HTMLBody = strbody & "<br>" & .HTMLBody
If Len(strAttachment) > 0 Then
If Len(Dir(strAttachment)) > 0 Then
.Attachments.Add strAttachment
End If
End If
Set .SendUsingAccount = oAccount
.Display
End With
End If
Set objMail = Nothing
Set objOutlook = Nothing

End If
Next

End Sub

Hopelijk dat iemand hier een oplossing voor heeft of mij op weg kan helpen.
Alvast bedankt voor de moeite.

Met vriendelijke groet,
René

 

[edmoor]

Je code is niet te lezen zo.
Zet dat tussen codetags.
Laat tevens weten op welke regel die foutmelding ontstaat.

 

[VenA]

Kan ook met VBA

Sub VenA()
  ar = Sheets("Op te volgen").Cells(1).CurrentRegion
  For j = 2 To UBound(ar)
    ar(j, 16) = (Format(ar(j, 1), "mmmdd") = Format(Date, "mmmdd")) And ar(j, 8) = "Ja"
    If ar(j, 16) Then
      strbody = "<br>" & "Beste " & ar(j, 13) & "<br>" & "Dit is het bericht <br>"
      With CreateObject("Outlook.Application").CreateItem(0)
        .To = ar(j, 14)
        .Subject = "Opvolging aanvraag " & Offertenummer & " t.n.v. " & NaamKlant
        .HTMLBody = strbody & "<br>" & .HTMLBody
        .SentOnBehalfOfName = "opvolging@test.nl"
        .display
      End With
    End If
  Next j
  Sheets("Op te volgen").Cells(1).CurrentRegion = ar
End Sub

 

[HSV]

Dit....

.SentOnBehalfOfName = "opvolging@test.nl"

is iets anders dan.....

Set .SendUsingAccount = oAccount

De rest heb ik maar klakkeloos overgenomen.

sub h()
 ar = Sheets("Op te volgen").Cells(1).CurrentRegion
  For j = 2 To UBound(ar)
    ar(j, 16) = (Format(ar(j, 1), "mmmdd") = Format(Date, "mmmdd")) And ar(j, 8) = "Ja"
    If ar(j, 16) Then
      strbody = "<br>" & "Beste " & ar(j, 13) & "<br>" & "Dit is het bericht <br>"
      With CreateObject("Outlook.Application").CreateItem(0)
        .To = ar(j, 14)
        .Subject = "Opvolging aanvraag " & Offertenummer & " t.n.v. " & NaamKlant
        .HTMLBody = strbody & "<br>" & .HTMLBody
[COLOR=#ff0000]         Set .SendUsingAccount = .session.accounts.Item("Opvolging@test.nl")[/COLOR]
        .display
      End With
    End If
  Next j
  Sheets("Op te volgen").Cells(1).CurrentRegion = ar
end sub

 

[RenevdH]

Beste VenA, HSV en edmoor,

De oplossingen van VenA en HSV werken perfect! Doet precies wat ik bedoelde. Ik ben er niet helemaal zeker van dat ik het helemaal snap, maar daar ga ik nog naar kijken (daar kom ik wel uit). Hartelijk dank voor de hulp.

@edmoor: sorry, je hebt helemaal gelijk en de volgende keer zal ik de code tussen codetags zetten.

Met groet,
René