I got the roots of the following code from a co-worker so I can't take credit. It uses the WMI interface to the scheduler service. It can be used to schedule a task at a predefined interval. The following code is dependent on a predifined global date which is used to hold the time of day for the task to be run. I use this to run a task every 15 minutes.
Usage:
1) Schedule your program to run "on startup" in the task sceduler via the GUI interface. Assign an admin, or other appropriate user context for it to run under.
2) In your program, (MyApp.exe)
...do something
' Set the start time to 15 minutes from now
gdtProcessTime = DateAdd("n",15,Now())
...do something
' Have the program reschedule itself for 15 minutes later
NTTaskDelete App.Path & "\MyApp.exe"
NTTaskCreate App.Path & "\MyApp.exe"
...
End
This sequence starts the app under the user account that is specified by the "startup" event. Since the program is using this account when it runs the new event that is "re-scheduled" uses the same user acount(default) to run under.
The "Exists" function at the end is not used in this sample but is useful sometimes.
Hope this is useful.
'--------------------------------
Public dtProcessTime as date
Private Sub NTTaskDelete(strCmdLine As String)
' this connects to the NT Task Scheduler via WMI to determine if the desired NT Scheduled Task Exists
' if found, it deletes it
Dim objTasks As Object
Dim objTask As Object
Dim strErr As String
On Error Resume Next
' now connect to NT Task Scheduler to determine if the script is scheduled
' create and schedule it if necessary
Set objTasks = GetObject("winmgmts:{impersonationLevel=impersonate}"
.InstancesOf("Win32_ScheduledJob"
If Err Then
strErr = ": " & Err.Number & " " & Err.Source & " " & Err.Description
App.LogEvent "NTTaskDelete: Could not delete the NT Task for " & strCmdLine & " due to error connecting to WMI: " & strErr, vbLogEventTypeWarning
Err.Clear
Exit Sub
End If
For Each objTask In objTasks
If UCase(objTask.Command) = UCase(strCmdLine) Then
' but if trap error if trying to delete
Err.Clear
objTask.Delete
If Err Then
strErr = ": " & Err.Number & " " & Err.Source & " " & Err.Description
App.LogEvent "NTTaskDelete: Could not delete the NT Task for " & strCmdLine & " due to error during delete: " & strErr, vbLogEventTypeWarning
Err.Clear
End If
Exit For
End If
Next
End Sub
Private Sub NTTaskCreate(strCmdLine As String)
Dim objList As Object
Dim objTask As Object
Dim strTime As String
Dim ret As Long
Dim strResult As String
Dim intJobID As Integer
Dim intNextHour As Integer
Dim intNextMinute As Integer
Dim strTimeOffset As String
' gdtProcessTime has already been incremented to the next start time
' determine which is the next hour for task to execute
intNextHour = DatePart("h", gdtProcessTime)
intNextMinute = DatePart("n", gdtProcessTime)
' example
' strTime = "********123000.000000-420"
' set it for real
' determine UCT Offset for this computer (Universal Coordinated Time)
' Note that there's always only 1 Win32_ComputerSystem obj, but have to use for-next anyway
Set objList = GetObject("winmgmts:{impersonationLevel=impersonate}"
.InstancesOf("Win32_ComputerSystem"
For Each objTask In objList
strTimeOffset = Trim$(objTask.CurrentTimeZone)
Exit For
Next
Set objTask = Nothing
Set objList = Nothing
strTime = "********" & Format$(intNextHour, "00"
& Format$(intNextMinute, "00"
& "00" & ".000000" & strTimeOffset ' -300"
Set objTask = GetObject("winmgmts:{impersonationLevel=impersonate}!Win32_ScheduledJob"
ret = objTask.Create(strCmdLine, strTime, False, , , False, intJobID)
Select Case ret
Case 0
strResult = "The request is accepted."
Case 1
strResult = "The request is not supported."
Case 2
strResult = "The user does not have the necessary access."
Case 8
strResult = "Interactive Process."
Case 9
strResult = "The directory path to the service executable file cannot be found."
Case 21
strResult = "Invalid parameters have been passed to the service."
Case 22
strResult = "The account that this service runs under is invalid or lacks the permissions to run the service."
End Select
If ret > 0 Then
' create failed, write event log entry
App.LogEvent "NTTaskCreate: Win32_ScheduledJob.Create Failed. :" & strResult, vbLogEventTypeError
End If
Set objTask = Nothing
End Sub
Public Function NTTaskExists(strCmdLine As String) As Boolean
' this connects to the NT Task Scheduler via WMI to determine if the desired NT Scheduled Task Exists
Dim objTasks As Object
Dim objTask As Object
NTTaskExists = False
' now connect to NT Task Scheduler to determine if the script is scheduled
' create and schedule it if necessary
Set objTasks = GetObject("winmgmts:{impersonationLevel=impersonate}"
.InstancesOf("Win32_ScheduledJob"
For Each objTask In objTasks
If UCase(objTask.Command) = UCase(strCmdLine) Then
NTTaskExists = True
Exit For
End If
Next
End Function
