' NAME: SurveyReminder.VBS
'
' AUTHOR: Alan dot Kaplan at VA dot gov
' DATE : 4/25/2011, 1/2/2013
'
' COMMENT: Runs a Survey reminder.
Option Explicit
Dim message, title, oIE
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")
Dim dStart, dEnd, strMsgTitle
'set to False if not testing. True will ignore the date restictions.
Dim bTest: bTest = true
'Use this is you want a picture in your IE window
dim strPicturePath
strPicturePath = "\\server\share\picture.jpg"
Dim strDaysList, strURL
'Use start and end dates
'dStart = "1/10/2012"
'dEnd = "1/15/2012"
'Run on certrain days January 15, January 22, January 28 and February 4th
strDaysList = ("1/15/2013,1/22/2013,1/28/2013,2/4/2013")
If bTest Then strDaysList = (Date)
Dim aDays: aDays = Split(strDaysList,",")
strMsgTitle = "Message from The Boss"
If bTest Then strMsgTitle = "TEST -- " & strMsgTitle
'this is the URL presented in the reminder window.
strURL = "http://asurvey.com/yoursurveyURL"
if bTest Then strURL = "http://www.google.com"
strPicturePath = "file://" & Replace(strPicturePath,"\","/")
message = "
"
If Len (strPicturePath) > 0 Then
message = message & " "
End If
'Edit the message here
message = message & "Please take the Survey! " & _
"It will only take several minutes for your opinion to be recorded.
" & _
"Please click this link to complete the survey: "&strURL&"
"
Dim bRun: bRun = False
If IsArray(aDays) Then
Dim i
For i = 0 To UBound(aDays)
If Date = CDate(aDays(i)) Then bRun = True
Next
Else
bRun = False
' uncomment if using start and end dates
If Date > cdate(dStart) Then bRun = False
If Date < CDate(dEnd) Then bRun = False
'Run on Odd Numbered days
'If Day(Now)/2 = Fix(Day(Now)/2) Then WScript.Quit
End If
If bRun = False Then WScript.Quit
dim fso,logfile, appendout, f
'marker file to show it has run
logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\SurveyMarkerFile.txt"
'setup log
Const ForAppend = 8
set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(logfile) Then
Set f= fso.GetFile(logfile)
if not BTest Then
If day(f.DateLastModified) = Day(Now) Then WScript.Quit
End If
End If
set AppendOut = fso.OpenTextFile(logfile, ForAppend, True)
appendout.writeline "Ran at " & Now
IEMessage message,strMsgTitle,"lt Blue",680,800,False
WScript.Sleep 20000
if IsObject(oIE) then oIE.Quit
'================ Functions and Subs ==============
Sub IEMessage(message,strTitle,strBGColor,iHeight,IWidth,bPrint)
Dim oPage
Dim strComputer, strBorder, strFont
Dim strFormatOn, strFormatOff, iTSView
Set oIE = CreateObject("InternetExplorer.Application")
iTSView = 0 '1 for troubleshooting, allows view source menu
strBorder = 1 'Best appearance is strBorder 1
strFont = "Arial"
oIE.Navigate "about:blank"
oIE.AddressBar = False
oIE.Height = iHeight
oIE.Width = IWidth
oIE.MenuBar = iTSView
oIE.ToolBar = iTSView
oIE.StatusBar = False
oIE.Left = 50
oIE.Top = 50
oIE.Visible = 1
message = Replace(message,vbcrlf," "& vbcrlf)
Do While (oIE.Busy)
Wscript.Sleep 250
Loop
Set oPage = oIE.Document
oPage.Open
oPage.Writeln "" & strTitle & ""
oPage.Writeln ""
oPage.Writeln ""
oPage.Writeln "
" & strTitle & "
"
oPage.Writeln "" & Message & " "
If bPrint Then
oPage.WriteLn ""
End If
oPage.Writeln ""
oPage.Write()
oPage.Close
End Sub