Variable mail in excel opstellen

[HWV]

Goedemorgen,

Ooit eens een script gekregen van HSV die ik heb aangepast naar wat ik nu nodig zou hebben.

Sub Mail_HSV()

Application.ScreenUpdating = False

Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
                    
On Error Resume Next
   sn = Sheets("Documenten_registratie").Cells(1).CurrentRegion.Resize(, 8)
   For j = 2 To UBound(sn)
     For x = j To UBound(sn)
       If sn(x, 3) = sn(j, 3) Then
      
        For jj = 3 To 8
            c00 = c00 & IIf(InStr(c00, sn(x, 2)) = 0, vbLf & sn(x, 1) & " - " & sn(x, 2) & vbLf, "") & "" & sn(1, jj) & ":  " & sn(x, jj) & vbLf
        Next jj
      
    End If
  
      Next x
    
 If c00 <> "" Then
      
    EmailSubject = "Artikelen die onder minimale voorraad komen, graag advies."
    EmailSendTo = Sheets("Klant").Cells(Application.Match(sn(j, 3), Sheets("Klant").Columns(1), 0), 3)
    Emailtav = Sheets("Klant").Cells(Application.Match(sn(j, 3), Sheets("Klant").Columns(1), 0), 5)
    Afzender = Environ("userName")
  
        With CreateObject("Outlook.Application").createitem(0)
            .Subject = EmailSubject
            .To = EmailSendTo
            .body = "Beste " & Emailtav & "," & vbNewLine & vbNewLine _
            & "Onderstaande zou weer aangemaakt moeten worden, graag advies of deze besteld moeten/mogen worden en met welke aantallen." _
            & vbLf & c00 & vbNewLine & "In afwachting van je reactie, zodra we een antwoord terug hebben zullen we zonodig de bestelling plaatsen." & vbNewLine & "Bij voorbaat dank voor je medewerking." & vbNewLine & vbNewLine & "Met vriendelijke groet," & vbNewLine & vbNewLine & Afzender & vbNewLine & "Bedrijfsnaam"
            .Display
        End With
      
        c00 = ""
 End If

 Next j

 End Sub

Dit werkt nu wel, maar enkel dat ik zoals in het voorbeeld staat ik twee mails krijg met elk 2 artikelen krijg ik 4 mails, met 2 x2 artikelen die goed is maar ook nog eens 2 mails met 1 artikel.
Ik zie niet waar het fout gaat, dus elke hulp is meegenomen.
Alvast dank

Henk

 

[HSV]

Test het zo eens weer Henk.

Sub Mail_HSV()
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Application.ScreenUpdating = False

On Error Resume Next
   sn = Sheets("Documenten_registratie").Cells(1).CurrentRegion.Resize(, 8)
 For j = 2 To UBound(sn)
  If InStr(s0, "|" & sn(j, 3) & "|") = 0 Then
    s0 = s0 & "|" & sn(j, 3) & "|"
      For x = j To UBound(sn)
        If sn(x, 3) = sn(j, 3) Then
           For jj = 3 To 8
            c00 = c00 & IIf(InStr(c00, sn(x, 2)) = 0, vbLf & sn(x, 1) & " - " & sn(x, 2) & vbLf, "") & "" & sn(1, jj) & ":  " & sn(x, jj) & vbLf
           Next jj
        End If
      Next x
    End If
 If c00 <> "" Then
         
    EmailSubject = "Artikelen die onder minimale voorraad komen, graag advies."
    EmailSendTo = Sheets("Klant").Cells(Application.Match(sn(j, 3), Sheets("Klant").Columns(1), 0), 3)
    Emailtav = Sheets("Klant").Cells(Application.Match(sn(j, 3), Sheets("Klant").Columns(1), 0), 5)
    Afzender = Environ("userName")
    
        With CreateObject("Outlook.Application").createitem(0)
            .Subject = EmailSubject
            .To = EmailSendTo
            .body = "Beste " & Emailtav & "," & vbNewLine & vbNewLine _
            & "Onderstaande zou weer aangemaakt moeten worden, graag advies of deze besteld moeten/mogen worden en met welke aantallen." _
            & vbLf & c00 & vbNewLine & "In afwachting van je reactie, zodra we een antwoord terug hebben zullen we zonodig de bestelling plaatsen." & vbNewLine & "Bij voorbaat dank voor je medewerking." & vbNewLine & vbNewLine & "Met vriendelijke groet," & vbNewLine & vbNewLine & Afzender & vbNewLine & "Bedrijfsnaam"
            .Display
        End With
    c00 = ""
 End If
Next j
End Sub

 

[HWV]

Harry,

Geweldig, deze doet nu idd 2 mails opstellen, met elk 2 artikelen erin.

* vervolg vraag
Weet jij of het mogelijk is dat ik onder de artikelen of in de bijlage's afbeeldingen kan zetten met als bestands naam de "code" van het artikel.
Deze staan dan ergens op mijn harde schijf.

Nogmaals dank, en mocht je een antwoord weten op mijn vervolg vraag dan hoor ik dit graag van je.

Groet Henk

 

[HSV]

Mooi Henk,

Ook dat kan in dit stukje via ".Attechment.add" in onderstaand stukje.

 With CreateObject("Outlook.Application").createitem(0)
            .Subject = EmailSubject
            .To = EmailSendTo
            .body = "Beste " & Emailtav & "," & vbNewLine & vbNewLine _
            & "Onderstaande zou weer aangemaakt moeten worden, graag advies of deze besteld moeten/mogen worden en met welke aantallen." _
            & vbLf & c00 & vbNewLine & "In afwachting van je reactie, zodra we een antwoord terug hebben zullen we zonodig de bestelling plaatsen." & vbNewLine & "Bij voorbaat dank voor je medewerking." & vbNewLine & vbNewLine & "Met vriendelijke groet," & vbNewLine & vbNewLine & Afzender & vbNewLine & "Bedrijfsnaam"
             .Attachments.add "c:/users/xxx/pictures/map1/foto1.jpg"
             .Display
        End With]/code]

Maar in dit geval zal het variabel moeten en waarschijnlijk meerdere bijlages in dezelfde mail.
Die gegevens moet je dan maar even in een nieuw bestandje zetten en even het bestandje hier weer plaatsen.

 

[HWV]

Harry,

.Attachments.Add "C:\Users\XX\XX\Logistiek\Verpakkingen\Afbeeldingen\foto1.jpg"

heb ik toegevoegd, maar idd deze moet varriable worden.
Ik heb al gekeken of ik het voor elkaar kreeg,

    Afbeelding = Sheets("Documenten_registratie").Cells(Application.Match(sn(j, 1), Sheets("Documenten_registratie").Columns(1), 0), 1)

en

            .Attachments.Add "C:\Users\XX\XX\Logistiek\Verpakkingen\Afbeeldingen\" & Afbeelding & ".jpg"

Maar zo makkelijk is het dus niet.

Groet Henk

 

[HSV]

Kijk maar eens of het lukt Henk.

Sub Mail_HSV()
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Application.ScreenUpdating = False
pad = "C:\Users\XX\XX\Logistiek\Verpakkingen\Afbeeldingen\"
 On Error Resume Next
   sn = Sheets("Documenten_registratie").Cells(1).CurrentRegion.Resize(, 8)
 For j = 2 To UBound(sn)
  If InStr(s0, "|" & sn(j, 3) & "|") = 0 Then
    s0 = s0 & "|" & sn(j, 3) & "|"
      For x = j To UBound(sn)
        If sn(x, 3) = sn(j, 3) Then
           foto = foto & "|" & sn(x, 1)
           For jj = 3 To 8
            c00 = c00 & IIf(InStr(c00, sn(x, 2)) = 0, vbLf & sn(x, 1) & " - " & sn(x, 2) & vbLf, "") & "" & sn(1, jj) & ":  " & sn(x, jj) & vbLf
           Next jj
        End If
      Next x
    End If
 If c00 <> "" Then
        
    EmailSubject = "Artikelen die onder minimale voorraad komen, graag advies."
    EmailSendTo = Sheets("Klant").Cells(Application.Match(sn(j, 3), Sheets("Klant").Columns(1), 0), 3)
    Emailtav = Sheets("Klant").Cells(Application.Match(sn(j, 3), Sheets("Klant").Columns(1), 0), 5)
    Afzender = Environ("userName")
       
        With CreateObject("Outlook.Application").createitem(0)
            .Subject = EmailSubject
            .To = EmailSendTo
            .body = "Beste " & Emailtav & "," & vbNewLine & vbNewLine _
            & "Onderstaande zou weer aangemaakt moeten worden, graag advies of deze besteld moeten/mogen worden en met welke aantallen." _
            & vbLf & c00 & vbNewLine & "In afwachting van je reactie, zodra we een antwoord terug hebben zullen we zonodig de bestelling plaatsen." & vbNewLine & "Bij voorbaat dank voor je medewerking." & vbNewLine & vbNewLine & "Met vriendelijke groet," & vbNewLine & vbNewLine & Afzender & vbNewLine & "Bedrijfsnaam"
        For Each bl In Split(Mid(foto, 2), "|")
            .Attachments.Add pad & bl & ".jpg"
        Next bl
            .Display
        End With
    c00 = ""
    foto = ""
 End If
Next j
End Sub

 

[HWV]

Harry,

Perfect hoe jij dit weer in elkaar heb gedraait!
Het doet wat het moet doen, en de afbeeldingen worden netjes in de bijlage erbij gezet.
Geweldig, bedankt weer.

groet Henk

 

[HSV]

Graag gedaan.