'Scheduling program. Launches programs, scripts, and 'batch files according to schedule entered in matching 'database. It will create the matching database (if 'needed) the first time it runs. Multiple instances 'of the script are blocked, but a side-effect of the 'blocking method is that you must wait 30+ seconds to 're-start the script after you stop it. 'Note: Database Month value is STRING, for example, 'use July, not 7. In all cases with numbers, DO NOT use 'leading zeros. You can use comma-delimited sets. For 'example, for a script that runs at 7AM and 5PM on 'weekdays, set the "Weekday" value to: 'Monday,Tuesday,Wednesday,Thursday,Friday '... and set the "Hour" value to: '7,17 Option Explicit Main Sub Main() Dim fs 'As Scripting.FileSystemObject Dim wsh 'As Wscript.Shell Dim dbeng 'As DAO.DBEngine Dim db 'As Database Dim rs 'As Recordset Dim strTest 'As String Dim dtLastCheck 'As Date Const dbOpenDynaset = 2 'DAO.RecordsetTypeEnum Const dbReadOnly = 4 'DAO.RecordsetOptionEnum Const dbOpenSnapshot = 4 'DAO.RecordsetTypeEnum Const dbOptimistic = 3 'DAO.LockTypeEnum 'Create objects Set fs = CreateObject("Scripting.FileSystemObject") Set wsh = CreateObject("Wscript.Shell") 'First check to see if a database file exists If Not fs.FileExists(FileNameLikeMine("mdb")) Then CreateDatabase End If 'Now open the database Set dbeng = CreateObject("DAO.DBEngine.36") Set db = dbeng.OpenDatabase(FileNameLikeMine("mdb"), False, False) 'Second thing is to see if another instance is running. 'Do this by looking at the LastLoopTime. Things are checked 'every 15 seconds, so a LastLoopTime of under 25 seconds implies 'another instance is already running. Not foolproof, but... Set rs = db.OpenRecordset("SELECT * FROM LastCheck;", dbOpenSnapshot, , dbReadOnly) On Error Resume Next 'ignore possibility of null/empty values dtLastCheck = CDate(0) 'initialize to old value dtLastCheck = rs.Fields("LastLoopTime").Value On Error Goto 0 'Turn error checking back on If IsDate(dtLastCheck) Then If DateDiff("s", dtLastCheck, Now) < 25 Then 'Another instance is running. Exit. rs.Close db.Close Exit Sub End If End If 'We are legitimate. Log the program start. WriteLog Now & vbTab & WScript.ScriptFullName 'Begin the infinite loop constantly checking the database Do 'First thing is to see if we are still at the same 'minute value as the last time we checked. If so, 'don't actually launch anything! Set rs = db.OpenRecordset("SELECT * FROM LastCheck;", dbOpenSnapshot, , dbReadOnly) On Error Resume Next 'ignore possibility of null/empty values dtLastCheck = CDate(0) 'initialize to old value dtLastCheck = rs.Fields("LastCheckTime").Value On Error Goto 0 'Turn error checking back on If Minute(dtLastCheck) <> Minute(Now) Then 'It's a new minute, okay to do something this time through the loop! 'First update the LastCheckTime Set rs = db.OpenRecordset("SELECT * FROM LastCheck;", dbOpenDynaset, , dbOptimistic) If rs.EOF Then rs.AddNew Else rs.Edit End If rs.Fields("LastCheckTime") = Now rs.Update rs.Close 'Now open the schedule and see what's there Set rs = db.OpenRecordset("SELECT * FROM Schedule;", dbOpenSnapshot, , dbReadOnly) If Not(rs.EOF And rs.BOF) Then Status Now & " -- checking." rs.MoveFirst 'Read each record in the database Do until rs.EOF Do 'Dummy loop to make skipping easier On Error Resume Next 'ignore possibility of null/empty values strTest = "" 'set initial value in case of null value strTest = rs.Fields("Year") 'get the field strTest = Replace(strTest, " ", "") 'remove spaces If strTest <> "" Then strTest = "," & strTest & "," 'bracket data with commas for easy compares If InStr(strTest, "," & Year(Now) & ",") = 0 Then Exit Do End If strTest = "" 'set initial value in case of null value strTest = rs.Fields("Month") 'get the field strTest = Replace(strTest, " ", "") 'remove spaces If strTest <> "" Then strTest = "," & strTest & "," 'bracket data with commas for easy compares If InStr(strTest, "," & MonthName(Month(Now)) & ",") = 0 Then Exit Do End If strTest = "" 'set initial value in case of null value strTest = rs.Fields("Weekday") 'get the field strTest = Replace(strTest, " ", "") 'remove spaces If strTest <> "" Then strTest = "," & strTest & "," 'bracket data with commas for easy compares If InStr(strTest, "," & WeekDayName(Weekday(Now)) & ",") = 0 Then Exit Do End If strTest = "" 'set initial value in case of null value strTest = rs.Fields("Day") 'get the field strTest = Replace(strTest, " ", "") 'remove spaces If strTest <> "" Then strTest = "," & strTest & "," 'bracket data with commas for easy compares If InStr(strTest, "," & Day(Now) & ",") = 0 Then Exit Do End If strTest = "" 'set initial value in case of null value strTest = rs.Fields("Hour") 'get the field strTest = Replace(strTest, " ", "") 'remove spaces If strTest <> "" Then strTest = "," & strTest & "," 'bracket data with commas for easy compares If InStr(strTest, "," & Hour(Now) & ",") = 0 Then Exit Do End If strTest = "" 'set initial value in case of null value strTest = rs.Fields("Minute") 'get the field strTest = Replace(strTest, " ", "") 'remove spaces If strTest <> "" Then strTest = "," & strTest & "," 'bracket data with commas for easy compares If InStr(strTest, "," & Minute(Now) & ",") = 0 Then Exit Do End If 'Time/Data entries pass all tests! Run it! WriteLog Now & vbTab & rs.Fields("Description") Status Now & " -- LAUNCHING: " & rs.Fields("Description") wsh.Run rs.Fields("CommandLine"), 0, False Exit Do 'Mandatory exit from dummy loop Loop rs.MoveNext Loop Else Status Now & " -- database is empty." End If Else Status Now End If rs.Close 'Now write the LastLoopTime Set rs = db.OpenRecordset("SELECT * FROM LastCheck;", dbOpenDynaset, , dbOptimistic) If rs.EOF Then rs.AddNew Else rs.Edit End If rs.Fields("LastLoopTime") = Now rs.Update rs.Close 'Sleep for 15 seconds before checking things again WScript.Sleep 15000 Loop End Sub Sub WriteLog(strText) Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Const ForAppending = 8 Set fs = CreateObject("Scripting.FileSystemObject") Set ts = fs.OpenTextFile(Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "log", ForAppending, True) ts.WriteLine strText ts.Close End Sub Function FileNameLikeMine(strFileExtension) 'As String 'Returns a file name the same as the script name except 'for the file extension. Dim fs 'As Object Dim strExtension 'As String Set fs = CreateObject("Scripting.FileSystemObject") strExtension = strFileExtension If Len(strExtension) < 1 Then strExtension = "txt" If strExtension = "." Then strExtension = "txt" If Left(strExtension,1) = "." Then strExtension = Mid(strExtension, 2) FileNameLikeMine = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & strExtension End Function Sub Status(strMessage) If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then Wscript.Echo strMessage End If End Sub Sub CreateDatabase() 'Creates a database with the same root name as the script 'but with an mdb file extension. Initializes the new database 'with a table also named after the script name. Dim dbeng 'As DAO.Dbengine Dim db 'As Database Dim td 'As TableDef Dim fld 'As Field Dim rs 'As Recordset Const dbDate = 8 'DAO.DataTypeEnum Const dbText = 10 'DAO.DataTypeEnum Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0" 'DAO.LanguageConstants Set dbeng = CreateObject("DAO.DBEngine.36") 'Create the database mdb file Set db = dbeng.CreateDatabase(FileNameLikeMine("mdb"), dbLangGeneral) 'Create the LastCheck table Set td = db.CreateTableDef("LastCheck") 'Create the LastCheck fields td.Fields.Append td.CreateField("LastLoopTime", dbDate) td.Fields.Append td.CreateField("LastCheckTime", dbDate) db.TableDefs.Append td 'Create the Schedule table Set td = db.CreateTableDef("Schedule") 'Create the Schedule fields td.Fields.Append td.CreateField("Description", dbText, 255) td.Fields.Append td.CreateField("CommandLine", dbText, 255) td.Fields.Append td.CreateField("Year", dbText, 255) td.Fields.Append td.CreateField("Month", dbText, 255) td.Fields.Append td.CreateField("Date", dbText, 255) td.Fields.Append td.CreateField("WeekDay", dbText, 255) td.Fields.Append td.CreateField("Hour", dbText, 255) td.Fields.Append td.CreateField("Minute", dbText, 255) db.TableDefs.Append td 'Clean up db.Close End Sub