Macro informatie van Excel naar e-mail

[mtyn]

Hi allemaal,

Ik heb wat werkzaamheden van iemand over genomen, onder meer het bijhouden van een aantal Excel files. Nu zit er in een van de files een Macro om vanuit Excel data te verzamelen en in een Outlook e-mail klaar te zetten voor verzending.

Sub SendChase()

Dim Email As String, Subj As String, Sender As String
        Dim Msg As String, URL As String
    Dim r As Integer, x As Double, zoek As Integer, rij As Integer
    
    Set ObjOutlook = CreateObject("Outlook.Application")
    Dim ObjMessage
    'Set ObjMessage = ObjOutlook.CreateItem(olMailItem)
    
' Hieronder moet je bij To het regelnummer van de laatste gevulde regel in je bestand vermelden.
    For r = 2 To 4
    
' IMPORTANT: Select sender mailbox RespourceCenter as default in Outlook in order to send automated e-mails from FC
        Set ObjMessage = ObjOutlook.CreateItem(olMailItem)
'       Get the email address
        ObjMessage.To = Cells(r, 15)
        'ObjMessage.SenderEmailAddress = "ons@email.com"
        'ObjMessage.SenderName = "Center"
        ObjMessage.SentOnBehalfOfName = "ons@email.com"
        ObjMessage.CC = "ons@email.com"
'       Message subject
        ObjMessage.Subject = Cells(r, 3) & "_Type " & Cells(r, 8)
        
'       Compose the message
        Msg = Msg & "Dear " & Cells(r, 14) & "," & vbCrLf & vbCrLf
            'Do Until Cells(r, 4) <> Cells(r + 1, 4)
                'r = r + 1
                'Msg = Msg & "€ " & Cells(r, 7) & Space(42) & Cells(r, 6) & vbCrLf
            'Loop
        'Msg = Msg & vbCrLf

 '      Replace spaces with %20 (hex)
       ' Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
        'Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
        ObjMessage.Body = Msg
        
    ObjMessage.display
        
    Next r
   
    'ActiveWorkbook.Save
End Sub

Dit gaat prima als ik dit voor 1 rij doe (For r = 2 To 2), er wordt dan een mooie e-mail klaar gezet, maar zodra ik data uit twee of meer rijen haal (For r = 2 To 3), komt in het tweede mailtje ook de tekst van de eerste e-mail te staan, en evt in de derde e-mail de tekst van de twee eerdere. Nu ben ik zelf helemaal niet thuis in deze materie en met zoeken op dit forum en mijn grote vriend Google ben ik na 2 uur ook al niet veel verder gekomen. Kan iemand wellicht aangeven waar het probleem zit?

Alvast veel bedankt voor de hulp!

 

[VenA]

Je moet de variabele msg leegmaken aan het begin van de loop

For r = 2 To 4
msg = ""

Volgens mij is dit voldoende.

Sub VenA()
  Dim r As Long
  For r = 2 To 4
    With CreateObject("Outlook.Application").createitem(0)
      .To = Cells(r, 15)
      .SentOnBehalfOfName = "ons@email.com"
      .CC = "ons@email.com"
      .Subject = Cells(r, 3) & "_Type " & Cells(r, 8)
      .body = "Dear " & Cells(r, 14) & "," & vbCrLf & vbCrLf
      .display
    End With
  Next r
End Sub

 

[mtyn]

Yes thanks dat werkt! Met jouw code lukt het btw niet. Als ik die uitvoer opent er maar 1 nieuwe e-mail in plaats van 2. Bedankt voor je snelle reactie!

 

[VenA]

Ik heb de code een beetje aangepast.