Mail laten loopen middels VBA

[resmatrix]

Hallo allemaal

Ik maak gebruik van een VBA code om mails te verzenden. Deze werkt prima.
Nu staat in de code een cel (A2) op basis waarvan de mail verzonden wordt.

Wat ik nu graag zou willen is dat de mails verzonden blijven worden totdat cel A2 geen contents meer bevat.

Kan dat?

Onderstaand de code:
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

strbody = "Bla" & vbNewLine & vbNewLine & _
"Bla." & vbNewLine & vbNewLine & _
"Bla." & vbNewLine & vbNewLine & _
"Bla:" & vbNewLine & _
Range("A2").Value & vbNewLine & vbNewLine & _
"Bla:" & vbNewLine & vbNewLine & _
Range("C2").Value & vbNewLine & vbNewLine & _
"Bla"

On Error Resume Next
With OutMail
.From = ""
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

ActiveWorkbook.Sheets("Werkblad3").Activate
Range("A2:I2").Select
Selection.ClearContents
Range("A3:I300").Select
Selection.Copy
Range("A2:N299").Select
ActiveSheet.Paste
End Sub

 

[snb]

Vervang die hele macro door:

sub simpeler()
With createobject("Outlook.application")
  for j=2 to 300
    With .CreateItem(0)
      .body =vbcr & cells(j,1) & vbcr & cells(j,3)
      .To = ""
      .CC = ""
      .BCC = ""
      .Subject = "test"
     .Send
    End With
  next
End with
End Sub

 

[resmatrix]

Dank voor je snelle reactie.

Helaas werkt het niet helemaal zoals ik gehoopt had.
Ik krijg hierbij een comileer fout (for zonder next)

Doe ik iets fout?

 

[trucker10]

Kijk ook eens in de code er zit een typo in applicatoin wijzig deze eens en test

 

[dnties]

Er lijkt nog een fout te staan, namelijk in With createobject("Outlook.applicatoin")
Lijkt een typefout, ik denk dat er Outlook.application zal moeten staan.

EDIT: Trucker was me voor

Hopelijk helpt dit wat.

Tijs.

 

[snb]

Typevaut verbeturt.
Next toegevoegd.

 

[resmatrix]

Dank,

De typo had ik zelf gezien en daar lag het niet aan.

er wordt een next verwacht in de regels...... maar dat gaat mij even te ver

Kortom hij doet het nog niet

 

[resmatrix]

Ok ik heb hem werkend,

Hij gaat alleen door tot mail 300 of zo terwijl er maar drie regels gevuld zijn.
Iedere keer wordt een regel opgeschoond dus zou hij in princiepe maar 3 mails moeten verzenden.

Ik weet echt niet waar dit fout gaat als iemand nog kan helpen graag

 

[Roncancio]

Dank,

De typo had ik zelf gezien en daar lag het niet aan.

er wordt een next verwacht in de regels...... maar dat gaat mij even te ver

Kortom hij doet het nog niet

SNB heeft de code in reactie #2 aangepast.
Als het goed is zou het moeten werken.

@snb.
Wellicht een idee om de verbeterde versie in de nieuwste reactie(s) te plaatsen zodat TS niet hoeft te zoeken. Tevens het risico vermijden dat men de verbeterde versie overslaat omdat deze zich in een van de eerste reacties staat.

Met vriendelijke groet,


Roncancio

 

[trucker10]

Ok ik heb hem werkend,

Hij gaat alleen door tot mail 300 of zo terwijl er maar drie regels gevuld zijn.
Iedere keer wordt een regel opgeschoond dus zou hij in princiepe maar 3 mails moeten verzenden.

Ik weet echt niet waar dit fout gaat als iemand nog kan helpen graag

Probeer de for j= 2 to 300 , pas deze aan for j=2 to 4 (?)

 

[resmatrix]

Thanx roncancio,

Klopt maar de code had ik inmiddels zelf al achterhaald, en werkt nu prima.

Het probleem wat ik nu heb is dat de mail verzonden blijft worden tot regen 300.
deze zou moeten stoppen als er in bv regel 6 geen data meer staat.

 

[Wigi]

Een simpele ingreep zou kunnen zijn:

sub simpeler()
With createobject("Outlook.application")
  for j=2 to 300
[B]If cells(j,1) = "" Then Exit For[/B]
    With .CreateItem(0)
      .body =vbcr & cells(j,1) & vbcr & cells(j,3)
      .To = ""
      .CC = ""
      .BCC = ""
      .Subject = "test"
     .Send
    End With
  next
End with
End Sub

 

[resmatrix]

Thanx Wigi :thumb:

Werkt perfect!

 

[snb]

sub simpeler()
  With createobject("Outlook.application")
    for each cl in columns(1).specialcells(xlcelltypeconstants)
      With .CreateItem(0)
        .body =vbcr & cl.value & vbcr & cl.offset(,2)
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "test"
        .Send
      End With
    Next
    .Quit
  End with
End Sub