Solved

Find dates in Excel with VBScript Part 2

Posted on 2014-04-04
8
321 Views
Last Modified: 2014-04-08
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

0
Comment
Question by:Brad Bouchard
  • 3
  • 3
8 Comments
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 39979433
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
 
LVL 65

Expert Comment

by:RobSampson
ID: 39979485
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
 
LVL 17

Author Comment

by:Brad Bouchard
ID: 39983843
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
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
ID: 39984699
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
 
LVL 17

Author Comment

by:Brad Bouchard
ID: 39986268
Rob,

Thanks.  Once again, you've made my day.  I appreciate the help.
0
 
LVL 17

Author Closing Comment

by:Brad Bouchard
ID: 39986270
Excellent work as always.
0
 
LVL 65

Expert Comment

by:RobSampson
ID: 39986374
Great. Thanks for the grade.

Rob.
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Script to copy or move mouse-selected collection of files plus targets referenced by shortcuts (.lnk) The purpose of this article is to help illuminate the real challenges and options available (where they may exist) for utilizing simple scriptin…
Welcome, welcome!  If you are new to the series and haven't been following along, please take a brief moment to review the first three installments: Part 1 (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/A_266-VBScri…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
This video gives you a great overview about bandwidth monitoring with SNMP and WMI with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're looking for how to monitor bandwidth using netflow or packet s…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now