Arun Kumar MA
Board Regular
- Joined
- Jan 10, 2012
- Messages
- 122
Hi all,
Iam using the below coding to trigger email to the receipient if the difference b/w todays date & DOJ is more than 104 days.
The mail gets triggerd but with below issues:
Any assistance will be highly appreciated.
Thanks & Regards
Arun
Iam using the below coding to trigger email to the receipient if the difference b/w todays date & DOJ is more than 104 days.
The mail gets triggerd but with below issues:
- The email body & email body 1 are drafted in the same even after using vbNewLine.
- I want a single mail to be sent to the supervisor for all the satisfying criterias as on that particular date, below is the header for reference.
- Also I need a signature to be added.
Code:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Range("H2").Value = Date
Dim myOutlook As Object
Dim myMailItem As Object
Dim FName As String
Dim DOJ As String
Dim Emailid As String
Dim i As Long
Dim PM As Range
Dim Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body, Email_Body1, Email_Body2, Email_Body3 As String
Worksheets("Sheet1").Activate
Home_Last_Row = Worksheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To Home_Last_Row
If Now() > Range("D" & i) + 104 Then
'If Range("E" & i) = Range("H2") Then
FName = Range("F" & i)
Emailid = Range("G" & i)
DOJ = Range("D" & i)
Exit For
End If
Next i
If DOJ = "" Then Exit Sub
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
CellRow = ActiveCell.Row
CellColumn = ActiveCell.Column
Email_Body = vbNewLine & "Dear " & FName & "," & vbNewLine & vbNewLine
Email_Body1 = vbNewLine & "The below mentioned resources has/have joined your team, would you pls rate them on the scale given below." & vbNewLine & vbNewLine
'Cells(ActiveCell.Row, 3).Value
Set PM = ActiveSheet.Range("L2:M8")
'PM = ActiveSheet.Range("N11")
Email_Body2 = PM
'Email_Body2 = Selection.Paste '& vbNewLine & vbNewLine & "Many Thanks" & vbNewLine & "Prasad - HR Team"
With otlNewMail
.To = Emailid
'.CC = Cells(1, 1)
.Subject = "Rate your team member."
.HTMLBody = Email_Body & Email_Body1 & RangetoHTML(PM) 'Email_Body2
.DeferredDeliveryTime = Range("H2")
.Send
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
'.Cells(1).Paste
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Columns("A:B").Select
.Columns("A:F").AutoFit
.Columns("A:A").ColumnWidth = 10
.Columns("B:B").ColumnWidth = 15
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publish the sheet to an .htm file.
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read all data from the .htm file into the RangetoHTML subroutine.
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
' Close TempWB.
TempWB.Close savechanges:=False
' Delete the htm file.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End FunctionAny assistance will be highly appreciated.
Thanks & Regards
Arun
