Shiroe2020
Addict
Hello
Sino po marunong mag VBA Macro dito.. hindi kasi nag aappear ung Outlook Signature ko kapag pineperform ko ung macro ko.. bakit po kaya.. ito po ung codes ko.
Sub Mail_Outlook_With_Signature_Html_1()
'Updated by Extendoffice 2018/11/22
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgSubject As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim i As Long
On Error Resume Next
Set xRgDate = Application.InputBox("Please select the DELIVERY DATE column:", "Email Follow-up Automation", , , , , , 8)
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Application.InputBox("Please select the RECIPIENTS column:", "Email Follow-up Automation", , , , , , 8)
If xRgSend Is Nothing Then Exit Sub
Set xRgSubject = Application.InputBox("Please select the SUBJECT column:", "Email Follow-up Automation", , , , , , 8)
If xRgSubject Is Nothing Then Exit Sub
Set xRgText = Application.InputBox("Please select the BODY OF MESSAGE column:", "Email Follow-up Automation", , , , , , 8)
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSubject = xRgSubject(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 3 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = xRgSubject.Offset(i - 1).Value
vbCrLf = "<br><br>"
xMailBody = "<HTML><BODY>"
xMailBody = xMailBody & "Hi, All. " & vbCrLf
xMailBody = xMailBody & "Good Day, " & vbCrLf
xMailBody = xMailBody & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & "</BODY></HTML>" & "<br><B>Thank you</B>"
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.CC = "Cusing.Kemuel01@gmail.com"
.HTMLBody = xMailBody & "<br>" & .HTMLBody
.Display
'.Send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
End Sub
Sino po marunong mag VBA Macro dito.. hindi kasi nag aappear ung Outlook Signature ko kapag pineperform ko ung macro ko.. bakit po kaya.. ito po ung codes ko.
Sub Mail_Outlook_With_Signature_Html_1()
'Updated by Extendoffice 2018/11/22
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgSubject As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim i As Long
On Error Resume Next
Set xRgDate = Application.InputBox("Please select the DELIVERY DATE column:", "Email Follow-up Automation", , , , , , 8)
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Application.InputBox("Please select the RECIPIENTS column:", "Email Follow-up Automation", , , , , , 8)
If xRgSend Is Nothing Then Exit Sub
Set xRgSubject = Application.InputBox("Please select the SUBJECT column:", "Email Follow-up Automation", , , , , , 8)
If xRgSubject Is Nothing Then Exit Sub
Set xRgText = Application.InputBox("Please select the BODY OF MESSAGE column:", "Email Follow-up Automation", , , , , , 8)
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSubject = xRgSubject(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 3 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = xRgSubject.Offset(i - 1).Value
vbCrLf = "<br><br>"
xMailBody = "<HTML><BODY>"
xMailBody = xMailBody & "Hi, All. " & vbCrLf
xMailBody = xMailBody & "Good Day, " & vbCrLf
xMailBody = xMailBody & xRgText.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & "</BODY></HTML>" & "<br><B>Thank you</B>"
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.CC = "Cusing.Kemuel01@gmail.com"
.HTMLBody = xMailBody & "<br>" & .HTMLBody
.Display
'.Send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
End Sub