Find dates in Excel with VBScript Part 2

I need to update some code and am not well versed in VB yet.  Please see this link from my previous question:  http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28396115.html

Rob did an awesome job helping me but I figured with all the extra comments I posted that it warranted a new question.  So, all I really need to do is take the bodyText part of the script and make that the actual body of the email.  I tried replacing .TextBody=strBody with .TextBody=bodyText, but it didn't work.

Help.

Edit:  I should mention that this is two scripts merged together.  Please find both of them separate below.  What I'm really trying to do is send email using CDO/SMTP rather than using Outlook as seen in my first script.
Dim objExcel
Dim objOutlook
Dim objMail
Dim objWB
Dim objWS
Dim vCell
Dim wsIndex, bodyText, blnServersFound, arrDateParts, dtePurchaseDate

Const xlUp = -4162
 
Set objExcel = CreateObject("Excel.Application")
 
objExcel.DisplayAlerts = False
objExcel.Visible = True
objExcel.Workbooks.Open ("E:\ServerInventory\ServerInventory.xlsx")
Set objWB = objExcel.ActiveWorkbook
bodyText = "The following servers are either at, or approaching, their 4 year end of life:" & vbNewLine & vbNewLine
blnServersFound = False
For wsIndex = 1 To objWB.Sheets.Count
    Set objWS = objWB.Worksheets(wsIndex)
    For Each vCell In objWS.Range("J2:J" & objWS.Cells(objWS.Rows.Count, "J").End(xlUp).Row).Cells
       	arrDateParts = Split(vCell, "/")
       	If UBound(arrDateParts) = 2 Then
            dtePurchaseDate = FormatDateTime(arrDateParts(1) & "/" & MonthName(arrDateParts(0), True) & "/" & arrDateParts(2))
			If Date >= DateAdd("yyyy", 4, FormatDateTime(dtePurchaseDate)) Then
				bodyText = bodyText & "Server " & objWS.Cells(vCell.Row, "B").Value & " (" & objWS.Cells(vCell.Row, "G").Value & " - " &_
					objWS.Cells(vCell.Row, "H").Value & ") has reached its end of life.  It was purchashed on " & dtePurchaseDate & vbNewLine
				blnServersFound = True
			End If
		End If
    Next
Next

If blnServersFound = True Then
	Set objOutlook = CreateObject("Outlook.Application")
	Set objMail = objOutlook.CreateItem(olMailItem)
	objMail.To = "user@domain.com"
	objMail.Subject = "Servers are at their EOL"
	objMail.Body = bodyText
	objMail.Send
	Set objMail = Nothing
	Set objOutlook = Nothing
End If
 
objWB.Save
objWB.Close
objExcel.Quit
 
Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing

Open in new window


strMessage = "SERVERS EXPIRING YOU IDIOT"
strTo= "user@domain.com"
strFrom="user@domain.com"
strSubject="Test Subject"
strAccountID="user"
strPassword="Password"
strSMTPServer="smtpserver.domain.com"
SendMail strTo,strFrom,strSubject,strMessage,strAccountID,strPassword,strSMTPServer


' send email using public mail servers
Function SendMail( strFrom, strSendTo, strSubject, strMessage , strUser, strPassword, strSMTP )

	Set oEmail = CreateObject("CDO.Message")
	
	'configure message
	With oEmail.Configuration.Fields
          .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
          .item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'basic
          .item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUser
          .item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPassword
          .Update
	End With
	
	' build message
	With oEmail
	     .From = strFrom
	     .To = strSendTo 
	     .Subject = strSubject
	     .TextBody = strMessage
	End With
	
	' send message
	On Error Resume Next
	oEmail.Send
	If Err Then
	     WScript.Echo "SendMail Failed:" & Err.Description
	End If
		
End Function

Open in new window

LVL 17
Brad BouchardInformation Systems Security OfficerAsked:
Who is Participating?
 
RobSampsonConnect With a Mentor Commented:
You are correct, that looks to be the only difference.  I have added that to my code.

Rob.

Dim objExcel
Dim objOutlook
Dim objMail
Dim objWB
Dim objWS
Dim vCell
Dim wsIndex, bodyText, blnServersFound, arrDateParts, dtePurchaseDate
Dim strServer, strTo, strFrom, strSubject

strServer = "mailhost.abc.com"
strTo = "user@domain.com"
strFrom = "john.doe@abc.com"
strSubject = "Servers expiring soon"
strUsername = "youruser@domain.com"
strPassword = "yourpassword"

Const xlUp = -4162
 
Set objExcel = CreateObject("Excel.Application")
 
objExcel.DisplayAlerts = False
objExcel.Visible = True
objExcel.Workbooks.Open ("C:\ServerInventory.XLSX")
Set objWB = objExcel.ActiveWorkbook
bodyText = "The following servers are nearing their 4 year replacement:" & vbNewLine & vbNewLine
blnServersFound = False
For wsIndex = 1 To objWB.Sheets.Count
    Set objWS = objWB.Worksheets(wsIndex)
    For Each vCell In objWS.Range("J2:J" & objWS.Cells(objWS.Rows.Count, "J").End(xlUp).Row).Cells
       	arrDateParts = Split(vCell, "/")
       	If UBound(arrDateParts) = 2 Then
            dtePurchaseDate = FormatDateTime(arrDateParts(1) & "/" & MonthName(arrDateParts(0), True) & "/" & arrDateParts(2))
			If Date >= DateAdd("yyyy", 4, FormatDateTime(dtePurchaseDate)) Then
				bodyText = bodyText & "Server " & objWS.Cells(vCell.Row, "B").Value & " (" & objWS.Cells(vCell.Row, "G").Value & " - " &_
					objWS.Cells(vCell.Row, "H").Value & ") has reached its end of life, which was " & dtePurchaseDate & vbNewLine
				blnServersFound = True
			End If
		End If
    Next
Next

If blnServersFound = True Then
	SendEmail strServer, strTo, strFrom, strSubject, bodyText, "", strUsername, strPassword
End If
 
objWB.Save
objWB.Close
objExcel.Quit
 
Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing

Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment, strUser, strPass)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
  		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
  		
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'basic
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUser
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPass
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

0
 
ltlbearand3Commented:
I am not sure that I follow exactly what you need.  What script are you working on.  You mention that your script is a combination of the two posted.  Can you please post the script you are working with and we can try and help you with it.
0
 
RobSampsonCommented:
Hi, here is my code that I use to send emails through an SMTP server, that I have added to your other code.  You can see I've just replaced the Outlook mail stuff with a call to the SendEmail procedure.

Regards,

Rob.

Dim objExcel
Dim objOutlook
Dim objMail
Dim objWB
Dim objWS
Dim vCell
Dim wsIndex, bodyText, blnServersFound, arrDateParts, dtePurchaseDate
Dim strServer, strTo, strFrom, strSubject

strServer = "mailhost.abc.com"
strTo = "user@domain.com"
strFrom = "john.doe@abc.com"
strSubject = "Servers expiring soon"

Const xlUp = -4162
 
Set objExcel = CreateObject("Excel.Application")
 
objExcel.DisplayAlerts = False
objExcel.Visible = True
objExcel.Workbooks.Open ("C:\ServerInventory.XLSX")
Set objWB = objExcel.ActiveWorkbook
bodyText = "The following servers are nearing their 4 year replacement:" & vbNewLine & vbNewLine
blnServersFound = False
For wsIndex = 1 To objWB.Sheets.Count
    Set objWS = objWB.Worksheets(wsIndex)
    For Each vCell In objWS.Range("J2:J" & objWS.Cells(objWS.Rows.Count, "J").End(xlUp).Row).Cells
       	arrDateParts = Split(vCell, "/")
       	If UBound(arrDateParts) = 2 Then
            dtePurchaseDate = FormatDateTime(arrDateParts(1) & "/" & MonthName(arrDateParts(0), True) & "/" & arrDateParts(2))
			If Date >= DateAdd("yyyy", 4, FormatDateTime(dtePurchaseDate)) Then
				bodyText = bodyText & "Server " & objWS.Cells(vCell.Row, "B").Value & " (" & objWS.Cells(vCell.Row, "G").Value & " - " &_
					objWS.Cells(vCell.Row, "H").Value & ") has reached its end of life, which was " & dtePurchaseDate & vbNewLine
				blnServersFound = True
			End If
		End If
    Next
Next

If blnServersFound = True Then
	SendEmail strServer, strTo, strFrom, strSubject, bodyText, ""
End If
 
objWB.Save
objWB.Close
objExcel.Quit
 
Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing

Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
  		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
  		
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25      
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

0
Get your problem seen by more experts

Be seen. Boost your question’s priority for more expert views and faster solutions

 
Brad BouchardInformation Systems Security OfficerAuthor Commented:
Rob,

Thanks for the reply.  Unfortunately no email gets sent when I use your code.  I am posting some code that does work by itself and am wondering if you could either tweak yours or help me integrate this into mine:

strMessage = "SERVERS EXPIRING YOU IDIOT"
strTo= "email@domain.com"
strFrom="email@domain.com"
strSubject="EOL Servers"
strAccountID="username"
strPassword="password"
strSMTPServer="smtp.server.domain"
SendMail strTo,strFrom,strSubject,strMessage,strAccountID,strPassword,strSMTPServer


' send email using public mail servers
Function SendMail( strFrom, strSendTo, strSubject, strMessage , strUser, strPassword, strSMTP )

	Set oEmail = CreateObject("CDO.Message")
	
	'configure message
	With oEmail.Configuration.Fields
          .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
          .item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'basic
          .item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUser
          .item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPassword
          .Update
	End With
	
	' build message
	With oEmail
	     .From = strFrom
	     .To = strSendTo 
	     .Subject = strSubject
	     .TextBody = strMessage
	End With
	
	' send message
	On Error Resume Next
	oEmail.Send
	If Err Then
	     WScript.Echo "SendMail Failed:" & Err.Description
	End If
		
End Function

Open in new window


I believe the only difference between yours and the one I originally used was that mine had authentication in it.
0
 
Brad BouchardInformation Systems Security OfficerAuthor Commented:
Rob,

Thanks.  Once again, you've made my day.  I appreciate the help.
0
 
Brad BouchardInformation Systems Security OfficerAuthor Commented:
Excellent work as always.
0
 
RobSampsonCommented:
Great. Thanks for the grade.

Rob.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.