Sub SendMailListReclamatieOrders()
Hier een andere code wat ik net liet zien is een omweg, maar eigenlijk moet het in onderstaande worden verwerkt dat als hij een email verstuurd dat de leverancier in een nieuw overzicht/sheet wordt gezet
Sub SendMailListReclamatieOrders()
Dim OutApp As Object
Dim OutMail As Object
Set WBMacro = ActiveWorkbook
Set WBMacroList = Sheets("Macro")
Set WBMailList = Sheets("Leveranciers")
Set OutApp = CreateObject("Outlook.Application")
If Len(Dir(WBMacro.Path & "" & Year(Now) & "\Week " & WorksheetFunction.WeekNum(Now, vbMonday) & "\Reclamatie", vbDirectory)) = 0 Then
MsgBox ("No 'Reclamatie' files have been created for week " & WorksheetFunction.WeekNum(Now, vbMonday) & " yet")
Exit Sub
End If
With WBMailList
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'.Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Cells(2, "A"), Order1:=xlAscending, _
' Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 4
emailsSent = 0
For i = iStart To LastRow
If StrComp(WBMacroList.Range("I" & 4).Value, WBMailList.Range("G" & i).Value) = 0 Or StrComp(WBMacroList.Range("I" & 4).Value, "Alle Productgroepen") = 0 Then
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SignatureName = WBMailList.Range("F" & 2).Value
SignatureName = Replace(SignatureName, " ", "%20")
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures" & WBMailList.Range("F" & 2).Value & ".htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Signature = VBA.Replace(Signature, (SignatureName & "_files"), (Environ("appdata") & "\Microsoft\Signatures" & SignatureName & "_files"))
Else
Signature = WBMailList.Range("F" & 1).Value
End If
On Error Resume Next
If Dir(WBMacro.Path & "" & Year(Now) & "\Week " & WorksheetFunction.WeekNum(Now, vbMonday) & "\Reclamatie\Reclamatie overzicht " & WBMailList.Range("B" & i).Value & ".xlsx") <> "" Then
With OutMail
.To = WBMailList.Range("C" & i).Value
.CC = ""
.BCC = ""
If WBMailList.Range("D" & i).Value = "Nederlands" Then
.Subject = "Reclamatie order overzicht week " & WorksheetFunction.WeekNum(Now, vbMonday)
.HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">" & WBMailList.Range("E" & i).Value & "<br>" & "<br>" & WBMailList.Range("B" & 1).Value & "<br>" & "<br>" & "<font>" & Signature
Else
.Subject = "Reclamation order overview week " & WorksheetFunction.WeekNum(Now, vbMonday)
.HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">" & WBMailList.Range("E" & i).Value & "<br>" & "<br>" & WBMailList.Range("B" & 2).Value & "<br>" & "<br>" & "<font>" & Signature
End If
'.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
.Attachments.Add (WBMacro.Path & "" & Year(Now) & "\Week " & WorksheetFunction.WeekNum(Now, vbMonday) & "\Reclamatie\Reclamatie overzicht " & WBMailList.Range("B" & i).Value & ".xlsx")
.Send 'or use .Display
emailsSent = emailsSent + 1
End With
On Error GoTo 0
End If
End If
Next i
MsgBox ("Totaal " & emailsSent & " reclamatie emails vertuurd.")
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub