Hi everyone,
I face a problem when I try to make an email reply using vba. My vba code send an email into a new conversation instead of reply to an existing subject.
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim tbl As String
Dim i As Integer
Dim lastRow As Long
Dim j As Integer
Dim mo As String
Dim redCount As Integer
Dim yellowCount As Integer
Dim greenCount As Integer
'hitung baris terakhir dengan data
lastRow = Sheets("AUTOMATION").Cells(Rows.Count, 1).End(xlUp).Row
tbl = "<table style='border-collapse: collapse; border: 1px solid black;'>"
tbl = tbl & "<tr><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>PART NAME</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>SPECIFICATION</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>MATERIAL CODE NUMBER</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>STOCK NOW</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>STATUS</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>PROCUREMENT STATUS</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>ETA</b></th><th style='border: 1px solid black; padding: 5px;background-color : #538DD5'><b>QTY TO BUY</b></th></tr>"
'reset value count
redCount = 0
yellowCount = 0
greenCount = 0
For i = 4 To lastRow
' periksa apakah nilai di kolom I kosong
mo = Sheets("AUTOMATION").Cells(i, 6).Value
If (Sheets("AUTOMATION").Cells(i, 5).Value = "RED" Or Sheets("AUTO-BUY").Cells(i, 5).Value = "YELLOW") Then
tbl = tbl & "<tr>"
For j = 1 To 8
tbl = tbl & "<td style='border: 1px solid black; padding: 5px;"
If j = 5 Then ' cek kolom status
If Sheets("AUTOMATION").Cells(i, j).Value = "RED" Then
redCount = redCount + 1
tbl = tbl & " background-color: red; color: white;"
ElseIf Sheets("AUTOMATION").Cells(i, j).Value = "YELLOW" Then
yellowCount = yellowCount + 1
tbl = tbl & " background-color: yellow;"
ElseIf Sheets("AUTOMATION").Cells(i, j).Value = "GREEN" Then
mo = ""
greenCount = greenCount + 1
tbl = tbl & " background-color: green; color: white;"
End If
End If
tbl = tbl & "'>" & Sheets("AUTOMATION").Cells(i, j).Value & "</td>"
Next j
tbl = tbl & "</tr>"
End If
Next i
redCount = Application.WorksheetFunction.CountIfs(Range("E:E"), "RED")
yellowCount = Application.WorksheetFunction.CountIfs(Range("E:E"), "YELLOW")
greenCount = Application.WorksheetFunction.CountIfs(Range("E:E"), "GREEN")
strBody = "Selamat Pagi Team. Jumlah Spare Part:" & vbCrLf
strBody = strBody & "- Status RED: " & redCount & " item" & vbCrLf
strBody = strBody & "- Status YELLOW: " & yellowCount & " item" & vbCrLf
strBody = strBody & "- Status GREEN: " & greenCount & " item." & vbCrLf
If tbl = "" Then
strBody = strBody & "Tidak ada Spare Part dengan Status RED atau YELLOW"
Else
tbl = tbl & "</table>" & vbCrLf & vbCrLf
strBody = strBody & "Detail Spare Part Dengan Status RED dan YELLOW" & vbCrLf & vbCrLf
strBody = strBody & tbl
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Range("Q3").Value
.CC = Range("Q4").Value
.BCC = ""
.Subject = "SPARE PART TO CHECK"
.HTMLBody = strBody
'export chart
Dim chartFilename As String
chartFilename = Environ$("temp") & "\SPARE PART CHART.png"
ActiveSheet.ChartObjects("SPARE PART CHART").Chart.Export chartFilename, "PNG"
'include chart to email
.Attachments.Add chartFilename, olByValue, 0
'delete file sementara chart
Kill chartFilename
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Here is my code.
How to change it so that it send an email in reply email instead of create a new email?
The reply subject is "SPARE PART TO CHECK" that already in the email
Bookmarks