?
Solved

Find dates in Excel with VBScript Part 2

Posted on 2014-04-04
8
Medium Priority
?
331 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 65

Accepted Solution

by:
RobSampson earned 2000 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

On Demand Webinar: Networking for the Cloud Era

Did you know SD-WANs can improve network connectivity? Check out this webinar to learn how an SD-WAN simplified, one-click tool can help you migrate and manage data in the cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Over the years I have built up my own little library of code snippets that I refer to when programming or writing a script.  Many of these have come from the web or adaptations from snippets I find on the Web.  Periodically I add to them when I come…
Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
In this video, Percona Solution Engineer Rick Golba discuss how (and why) you implement high availability in a database environment. To discuss how Percona Consulting can help with your design and architecture needs for your database and infrastr…
How to fix incompatible JVM issue while installing Eclipse While installing Eclipse in windows, got one error like above and unable to proceed with the installation. This video describes how to successfully install Eclipse. How to solve incompa…
Suggested Courses

801 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