1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:
635:
636:
637:
638:
639:
640:
641:
642:
643:
644:
645:
646:
647:
648:
649:
650:
651:
652:
653:
654:
655:
656:
657:
658:
659:
660:
661:
662:
663:
664:
665:
666:
667:
668:
669:
670:
671:
672:
673:
|
Option Explicit
Option Compare Text
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const SC_MANAGER_CONNECT = &H1, SC_MANAGER_CREATE_SERVICE = 2
Private Const SC_MANAGER_ENUMERATE_SERVICE = &H4, SC_MANAGER_LOCK = 8
Private Const SC_MANAGER_QUERY_LOCK_STATUS = &H10, SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
Private Const SC_MANAGER_ALL_ACCESS = SC_MANAGER_CONNECT + SC_MANAGER_CREATE_SERVICE + SC_MANAGER_ENUMERATE_SERVICE + SC_MANAGER_LOCK + SC_MANAGER_QUERY_LOCK_STATUS + SC_MANAGER_MODIFY_BOOT_CONFIG
Private Const SERVICE_QUERY_CONFIG = &H1, SERVICE_CHANGE_CONFIG = 2
Private Const SERVICE_QUERY_STATUS = &H4, SERVICE_ENUMERATE_DEPENDENTS = &H8
Private Const SERVICE_START = &H10, SERVICE_STOP = &H20, SERVICE_USER_DEFINED_CONTROL = &H100
Private Const SERVICE_PAUSE_CONTINUE = &H40, SERVICE_INTERROGATE = 128
Private Const SERVICE_ALL_ACCESS = SERVICE_QUERY_CONFIG + SERVICE_CHANGE_CONFIG + SERVICE_QUERY_STATUS + SERVICE_ENUMERATE_DEPENDENTS + SERVICE_STOP + SERVICE_START + SERVICE_PAUSE_CONTINUE + SERVICE_INTERROGATE + SERVICE_USER_DEFINED_CONTROL
Private Const SERVICE_STOPPED = 1, SERVICE_START_PENDING = 2
Private Const SERVICE_STOP_PENDING = 3, SERVICE_RUNNING = 4, SERVICE_PAUSED = 7
Private Const SERVICE_CONTINUE_PENDING = 5, SERVICE_PAUSE_PENDING = 6
Private Const SERVICE_BOOT_START = 0, SERVICE_SYSTEM_START = 1
Private Const SERVICE_AUTO_START = 2, SERVICE_DEMAND_START = 3, SERVICE_DISABLED = 4
Private Const SERVICE_CONTROL_STOP = 1, SERVICE_CONTROL_PAUSE = 2, SERVICE_CONTROL_SHUTDOWN = 5
Private Const SERVICE_CONTROL_CONTINUE = 3, SERVICE_CONTROL_INTERROGATE = 4
Private Const ERROR_MORE_DATA = 234, ERROR_ACCESS_DENIED = 5
Private Const ERROR_INVALID_HANDLE = 6, ERROR_PATH_NOT_FOUND = 3
Private Const ERROR_SERVICE_ALREADY_RUNNING = 1056, ERROR_DATABASE_LOCKED = 1055
Private Const ERROR_SERVICE_DEPENDENCY_DELETED = 1075, ERROR_SERVICE_DEPENDENCY_FAIL = 1068
Private Const ERROR_SERVICE_DISABLED = 1058, ERROR_SERVICE_LOGON_FAILED = 1069
Private Const ERROR_SERVICE_MARKED_FOR_DELETE = 1072, ERROR_SERVICE_NO_THREAD = 1054
Private Const ERROR_SERVICE_REQUEST_TIMEOUT = 1053, ERROR_SERVICE_DOES_NOT_EXIST = 1060
Private Const ERROR_SERVICE_CANNOT_ACCEPT_CONTROL = 1061, ERROR_SERVICE_NOT_ACTIVE = 1062
Private Const ERROR_SERVICE_SPECIFIC_ERROR = 1066, ERROR_SERVICE_START_HANG = 1070
Private Const ERROR_SERVICE_EXISTS = 1073, ERROR_SERVICE_NEVER_STARTED = 1077
Private Const ERROR_SERVICE_NOT_FOUND = 1243, ERROR_INSUFFICIENT_BUFFER = 122
Private Const ERROR_DATABASE_DOES_NOT_EXIST = 1065, ERROR_INVALID_PARAMETER = 87
Private Const ERROR_INVALID_NAME = 123
Private Const SERVICE_ACTIVE = &H1, SERVICE_INACTIVE = &H2
Private Const SERVICE_WIN32_OWN_PROCESS As Long = &H10, SERVICE_WIN32_SHARE_PROCESS As Long = &H20
Private Const SERVICE_WIN32 As Long = SERVICE_WIN32_OWN_PROCESS + SERVICE_WIN32_SHARE_PROCESS
Private Const JOB_RUN_PERIODICALLY = &H1, JOB_EXEC_ERROR = &H2
Private Const JOB_RUNS_TODAY = &H4, JOB_ADD_CURRENT_DATE = &H8, JOB_NONINTERACTIVE = &H10
Public Enum eDayOfWeek
dowMonday = 1
dowTuesday = 2
dowWednesday = 4
dowThursday = 8
dowFriday = 16
dowSaturday = 32
dowSunday = 64
End Enum
Private Type AT_ENUM
dwJobId As Long
dwJobTime As Long
dwDaysOfMonth As Long
dwDaysOfWeek As Byte
dwFlags As Byte
dwdummy As Integer
lptCommand As Long
End Type
Private Type AT_INFO
dwJobTime As Long
dwDaysOfMonth As Long
dwDaysOfWeek As Byte
dwFlags As Byte
dwdummy As Integer
lptCommand As Long
End Type
Private Type SERVICE_STATUS
dwServiceType As Long
dwCurrentState As Long
dwControlsAccepted As Long
dwWin32ExitCode As Long
dwServiceSpecificExitCode As Long
dwCheckPoint As Long
dwWaitHint As Long
End Type
Private Type QUERY_SERVICE_CONFIG
dwServiceType As Long
dwStartType As Long
dwErrorControl As Long
lpBinaryPathName As Long
lpLoadOrderGroup As Long
dwTagId As Long
lpDependencies As Long
lpServiceStartName As Long
lpDisplayName As Long
End Type
Private Type ENUM_SERVICE_STATUS
lpServiceName As Long
lpDisplayName As Long
ServiceStatus As SERVICE_STATUS
End Type
Private Declare Function OpenSCManager Lib "advapi32.dll" Alias "OpenSCManagerA" (ByVal lpMachineName As String, ByVal lpDatabaseName As String, ByVal dwDesiredAccess As Long) As Long
Private Declare Function CloseServiceHandle Lib "advapi32.dll" (ByVal hSCObject As Long) As Long
Private Declare Function OpenService Lib "advapi32.dll" Alias "OpenServiceA" (ByVal hSCManager As Long, ByVal lpServiceName As String, ByVal dwDesiredAccess As Long) As Long
Private Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyW" (RetVal As Byte, ByVal Ptr As Long) As Long
Private Declare Function StrToPtr Lib "kernel32" Alias "lstrcpyW" (ByVal Ptr As Long, Source As Byte) As Long
Private Declare Function PtrToInt Lib "kernel32" Alias "lstrcpynW" (RetVal As Any, ByVal Ptr As Long, ByVal nCharCount As Long) As Long
Private Declare Function StrLen Lib "kernel32" Alias "lstrlenW" (ByVal Ptr As Long) As Long
Private Declare Function QueryServiceStatus Lib "advapi32.dll" (ByVal hService As Long, lpServiceStatus As Any) As Long
Private Declare Function StartService Lib "advapi32.dll" Alias "StartServiceA" (ByVal hService As Long, ByVal dwNumServiceArgs As Long, ByVal lpServiceArgVectors As Long) As Long
Private Declare Function QueryServiceConfig Lib "advapi32.dll" Alias "QueryServiceConfigA" (ByVal hService As Long, lpServiceConfig As Any, ByVal cbBufSize As Long, pcbBytesNeeded As Long) As Long
Private Declare Function ControlService Lib "advapi32.dll" (ByVal hService As Long, ByVal dwControl As Long, lpServiceStatus As Any) As Long
Private Declare Function EnumServicesStatus Lib "advapi32.dll" Alias "EnumServicesStatusA" (ByVal hSCManager As Long, ByVal dwServiceType As Long, ByVal dwServiceState As Long, lpServices As Any, ByVal cbBufSize As Long, pcbBytesNeeded As Long, lpServicesReturned As Long, lpResumeHandle As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function NetScheduleJobGetInfo Lib "netapi32" (Servername As Byte, ByVal JobId As Long, PointerToBuffer As Any) As Long
Private Declare Function NetScheduleJobEnum Lib "netapi32" (Servername As Byte, PointerToBuffer As Any, PrefMaxLength As Long, EntriesRead As Long, TotalEntries As Long, ResumeHandle As Long) As Long
Private Declare Function NetScheduleJobDel Lib "netapi32" (Servername As Byte, ByVal MinJobId As Long, ByVal MaxJobId As Long) As Long
Private Declare Function NetScheduleJobAdd Lib "netapi32" (Servername As Byte, PointerToBuffer As AT_INFO, JobInfo As Long) As Long
Private Declare Function NetApiBufferFree Lib "NETAPI32.DLL" (ByVal Ptr As Long) As Long
Private Declare Function NetAPIBufferAllocate Lib "NETAPI32.DLL" Alias "NetApiBufferAllocate" (ByVal ByteCount As Long, Ptr As Long) As Long
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
'Purpose : Returns the state of the Service Control Manager
'Inputs : [sComputer] The name of the computer to test. If not specified uses local machine.
'Outputs : Returns 0 If the SCM is running
' 1 If the SCM is stopped
' 2 If unable to open/connect to the SCM
' 3 If unable to determine the state of the SCM
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ScheduleState(Optional ByVal sComputer As String) As Long
Dim lhSCM As Long, lhService As Long, sState As String, lReturn As Long
If Left$(sComputer, 2) <> "\\" And Len(sComputer) > 0 Then
sComputer = "\\" & sComputer
End If
'Connect to Service Control Manager
lhSCM = OpenSCManager(sComputer & vbNullString, vbNullString, SC_MANAGER_CONNECT)
If lhSCM = 0 Then
ScheduleState = 2
Exit Function
End If
'Connect to Schedule service
lhService = zServiceConnect(lhSCM, "Schedule")
If lhService = 0 Then
ScheduleState = 2
Exit Function
End If
'Get the service state
sState = ServiceGetState(lhService)
If Len(sState) = 0 Then
'Failed to determine the state of Schedule service
ScheduleState = 3
Exit Function
End If
If UCase$(sState) = "STARTED" Then
ScheduleState = 0 'Schedule Service is running
Else
ScheduleState = 1 'Schedule Service is Stopped
End If
End Function
'Purpose : Starts the Schedule Service
'Inputs : [sComputer] The name of the computer to test. If not specified uses local machine.
'Outputs : Returns A descriptive string (see function)
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ScheduleServiceStart(Optional ByVal sComputer As String) As String
Dim lhSCM As Long, lhService As Long
If Left$(sComputer, 2) <> "\\" And Len(sComputer) > 0 Then
sComputer = "\\" & sComputer
End If
'Connect to SCM and Schedule Service
lhSCM = OpenSCManager(sComputer & vbNullString, vbNullString, SC_MANAGER_ALL_ACCESS)
If lhSCM = 0 Then
ScheduleServiceStart = "Failed to connect"
Exit Function
End If
lhService = zServiceConnect(lhSCM, "Schedule")
If lhService = 0 Then
ScheduleServiceStart = "Failed to connect"
Exit Function
End If
'Start the service
If StartService(lhService, 0, 0) = 0 Then
ScheduleServiceStart = "Error " & GetLastError
Else
'Wait for service to start
Do
DoEvents
ScheduleServiceStart = ServiceGetState(lhService)
If ScheduleServiceStart = "Unknown" Then
Exit Do
End If
Loop Until ScheduleServiceStart = "Started"
End If
End Function
'Purpose : Returns the StartUp state of a Service
'Inputs : lhSCM A handle to a service
'Outputs : Returns A descriptive string (see code in function)
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Private Function zServiceStartState(lhSCM As Long) As String
Dim pState() As QUERY_SERVICE_CONFIG
Dim lReturn As Long, lBuffer As Long
Dim lBytesNeeded As Long, lStructNeeded As Long
lReturn = QueryServiceConfig(lhSCM, ByVal &H0, &H0, lBytesNeeded)
If GetLastError <> ERROR_INSUFFICIENT_BUFFER Then
zServiceStartState = "Unknown"
Exit Function
End If
'Calculate the buffer sizes
lStructNeeded = lBytesNeeded / Len(pState(0)) + 1
ReDim pState(lStructNeeded - 1)
lBuffer = lStructNeeded * Len(pState(0))
lReturn = QueryServiceConfig(lhSCM, pState(0), lBuffer, lBytesNeeded)
Select Case pState(0).dwStartType
Case SERVICE_BOOT_START
zServiceStartState = "Boot"
Case SERVICE_SYSTEM_START
zServiceStartState = "System"
Case SERVICE_AUTO_START
zServiceStartState = "Automatic"
Case SERVICE_DISABLED
zServiceStartState = "Disabled"
Case SERVICE_DEMAND_START
zServiceStartState = "Manual"
Case Else
zServiceStartState = "Unknown"
End Select
End Function
'Purpose : Connects to the specified service
'Inputs : lhSCM Handle to the SCM
' sServiceName The name of the service to connect to
'Outputs : Returns Handle to the service OR zero if not able to open service
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Private Function zServiceConnect(lhSCM As Long, sServiceName As String) As Long
'Open the Service Name
zServiceConnect = OpenService(lhSCM, sServiceName, SERVICE_ALL_ACCESS)
If zServiceConnect = 0 Then
Call CloseServiceHandle(lhSCM)
End If
End Function
'Purpose : Returns the state of the specified service
'Inputs : lhService Handle to the Service
'Outputs : Returns Descriptive text (See Function Code)
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ServiceGetState(lhService As Long) As String
Dim pstatus As SERVICE_STATUS
Dim lReturn As Long
lReturn = QueryServiceStatus(lhService, pstatus)
If lReturn <> 1 Then
lReturn = CloseServiceHandle(lhService)
ServiceGetState = ""
End If
Select Case pstatus.dwCurrentState
Case SERVICE_STOPPED
ServiceGetState = "Stopped"
Case SERVICE_START_PENDING
ServiceGetState = "Start Pending"
Case SERVICE_STOP_PENDING
ServiceGetState = "Stop Pending"
Case SERVICE_RUNNING
ServiceGetState = "Started"
Case SERVICE_CONTINUE_PENDING
ServiceGetState = "Continue Pending"
Case SERVICE_PAUSE_PENDING
ServiceGetState = "Pause Pending"
Case SERVICE_PAUSED
ServiceGetState = "Paused"
Case Else
ServiceGetState = "Unknown"
End Select
End Function
'Purpose : Enumerates the pending jobs on the specified machine
'Inputs : [sComputer] The name of the computer to test. If not specified uses local machine.
'Outputs : asJobs A string array (1 to 3, 1 to Number of Jobs)
' Where asJobs(1,1) Job 1. Command string
' asJobs(2,1) Job 1. Time string
' asJobs(3,1) Job 1. Date string
' asJobs(4,1) Job 1. Job ID
' Returns The number of jobs
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ServiceEnumJobs(asJobs() As String, Optional ByVal sComputer As String) As Long
Dim tJobDetails As AT_ENUM
Dim abytServer() As Byte, abytCommand(0 To 99) As Byte
Dim sCommand As String, sTemp As String
Dim sTime As String, sDayInfo As String
Dim lResume As Long, lEntriesRead As Long, lBuffer As Long
Dim lTotalEntries As Long, lThisJob As Long, lLenStruct As Long
Dim lptr As Long, lStartBuffer As Long, lBufferLen As Long
Const clMaxBufferLen As Long = 255
If Left$(sComputer, 2) <> "\\" And Len(sComputer) > 0 Then
sComputer = "\\" & sComputer
End If
abytServer() = sComputer & vbNullChar
lBufferLen = clMaxBufferLen
Call NetScheduleJobEnum(abytServer(0), lStartBuffer, lBufferLen, lEntriesRead, lTotalEntries, lResume)
lBuffer = lStartBuffer
lLenStruct = Len(tJobDetails)
Erase asJobs
If lBuffer <> 0 Then
ServiceEnumJobs = lTotalEntries
ReDim asJobs(1 To 4, 1 To lTotalEntries)
For lThisJob = 1 To lTotalEntries
'Copy pointer into structure
CopyMem tJobDetails, ByVal lBuffer, lLenStruct
'Get Command Line
lptr = tJobDetails.lptCommand
Call PtrToStr(abytCommand(0), lptr)
sCommand = Left$(abytCommand, StrLen(lptr))
asJobs(1, lThisJob) = sCommand
'Get Time
sTime = zServiceConvertTime(tJobDetails.dwJobTime)
asJobs(2, lThisJob) = sTime
'Get Day Info
sDayInfo = zGetDayInfo(tJobDetails.dwDaysOfMonth, tJobDetails.dwDaysOfWeek, tJobDetails.dwFlags)
asJobs(3, lThisJob) = sDayInfo
'Get Job ID
asJobs(4, lThisJob) = CStr(tJobDetails.dwJobId)
'Move pointer along by length of structure
lBuffer = lBuffer + lLenStruct
Next
End If
Call NetApiBufferFree(lStartBuffer)
End Function
'Purpose : Convert a decimal to a binary string
'Inputs : lValue A decimal (long) number
'Outputs : Returns A binary string representation of a numerical value
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Private Function zConvertToBinary(lValue As Long) As String
Dim lTestDiv As Long, lNumber As Long, lAbsValue As Long
lAbsValue = Abs(lValue)
lNumber = 32768
Do
lTestDiv = lAbsValue \ lNumber
If lTestDiv = 1 Then
'Number divisible, put the bit in the binary string
zConvertToBinary = zConvertToBinary & "1"
'Determine the remainder
lAbsValue = lAbsValue Mod lNumber
Else
'Number not divisible, put 0 in the binary string
zConvertToBinary = zConvertToBinary & "0"
End If
'Get the next bit
lNumber = lNumber / 2
If lNumber < 1 Then
'Finished
Exit Do
End If
Loop
End Function
'Purpose : Convert Milliseconds (from midnight) to a real time
'Inputs : lMSec Time in milliseconds
'Outputs : Returns A formated time string of the form "hh:mm:ss"
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Private Function zServiceConvertTime(lMSec As Long) As String
Dim lSeconds As Long
lSeconds = lMSec \ 1000
zServiceConvertTime = Format$(DateAdd("s", lSeconds, "00:00"), "hh:mm:ss")
End Function
'Purpose : Interprets AT_ENUM to return a string representing the schedule days
'Inputs : lMonth Days of month (as a long)
' bDay Days of week (as byte)
' bFlag Flags (as byte)
'Outputs : Returns A formated string representing the scheduled days
' eg "Each Tue Thur"
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes : Currently Days of Month NOT interpreted
'Revisions :
'Assumptions :
Private Function zGetDayInfo(lMonth As Long, bDay As Byte, bFlag As Byte) As String
Dim sMonth As String, sDay As String, sFlag As String
Dim lThisDay As Long
Dim asDays(1 To 7) As String
asDays(1) = "Mon"
asDays(2) = "Tue"
asDays(3) = "Wed"
asDays(4) = "Thu"
asDays(5) = "Fri"
asDays(6) = "Sat"
asDays(7) = "Sun"
'Convert the input data into a binary string
sMonth = zConvertToBinary(lMonth)
sDay = Right$(zConvertToBinary(Val(bDay)), 7)
sFlag = Right$(zConvertToBinary(Val(bFlag)), 8)
'Interpret the binary string for Days
For lThisDay = 7 To 1 Step -1
If Mid$(sDay, lThisDay, 1) = "1" Then
If Len(zGetDayInfo) = 0 Then
zGetDayInfo = asDays((7 - lThisDay) + 1)
Else
zGetDayInfo = zGetDayInfo & (" " & asDays((7 - lThisDay) + 1))
End If
End If
Next
If Left$(sFlag, 1) = "1" Then
zGetDayInfo = "Next: " & zGetDayInfo
Else
If Right$(sFlag, 1) = "1" Then
zGetDayInfo = "Each: " & zGetDayInfo
End If
End If
End Function
'Purpose : Returns information of a specified job for a
'specified computer
'Inputs : lJob The index of the job to return the details of
' [sComputer] The name of the computer to test. If not specified uses local machine.
'Outputs : Returns A binary string representation of a numerical value
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ServiceGetJobInfo(lJob As Long, Optional ByVal sComputer As String) As Variant
Dim abytServer() As Byte, abytCommand(0 To 99) As Byte
Dim sCommand As String, sTemp As String, avResults As Variant
Dim sTime As String, sDayInfo As String
Dim lptrCommand As Long
Dim lBuffer As Long, lResult As Long
Dim tBuffer As AT_INFO
On Error Resume Next
If Left$(sComputer, 2) <> "\\" And Len(sComputer) > 0 Then
sComputer = "\\" & sComputer
End If
abytServer() = sComputer & vbNullChar
Call NetScheduleJobGetInfo(abytServer(0), lJob, lBuffer)
CopyMem tBuffer, ByVal lBuffer, Len(tBuffer)
lptrCommand = tBuffer.lptCommand
lResult = PtrToStr(abytCommand(0), lptrCommand)
sCommand = Left(abytCommand, StrLen(lptrCommand))
sTime = zServiceConvertTime(tBuffer.dwJobTime)
sDayInfo = zGetDayInfo(tBuffer.dwDaysOfMonth, tBuffer.dwDaysOfWeek, tBuffer.dwFlags)
ReDim avResults(1 To 3)
avResults(1) = sCommand
avResults(2) = sTime
avResults(3) = sDayInfo
ServiceGetJobInfo = avResults
End Function
'Purpose : Delete a job/s from the schedule
'Inputs : lMinID The ID of the first job to
Delete
' [lMaxID] The ID of the last job to delete. If not specified job lMinID is deleted.
' [sComputer] The name of the computer to test. If not specified uses local machine.
'Outputs : Returns True if the job was deleted
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ServiceDeleteJob(lMinID As Long, Optional lMaxID As Long = -1, Optional ByVal sComputer As String) As Boolean
Dim abytServer() As Byte
If Left$(sComputer, 2) <> "\\" And Len(sComputer) > 0 Then
sComputer = "\\" & sComputer
End If
abytServer = sComputer & vbNullChar
If lMaxID = -1 Then
'Delete just lMinID
lMaxID = lMinID
End If
If NetScheduleJobDel(abytServer(0), lMinID, lMaxID) = 0 Then
ServiceDeleteJob = True
End If
End Function
'Purpose : Add a job to the schedule
'Inputs : sTime The time to run the schedule. In the format hh:mm eg. 17:00 (five o'clock)
' eWeekDay Enumerated type. Can be more than one value
' eg. dowWednesday +
dowThursday dowFriday
' sCommadLine The command line eg. "C: \MyApp.exe"
' Note: it may be necessary to use chr$(34) & C:\folder 1\MyApp.exe & chr$(34)
' when the directory contains spaces.
' lFlags 0 The service is run
Once
' 1 The service is run periodically for the week days specified in eWeekDay
' [sComputer] The name of the computer to test. If not specified uses local machine.
'Outputs : Returns True if the job was added
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function ServiceAddJob(sTime As String, eWeekDay As eDayOfWeek, sCommadLine As String, Optional lFlags As Long = 1, Optional sComputer As String) As Boolean
Dim abytServer() As Byte, abytCmd() As Byte
Dim tInfo As AT_INFO
Dim lReturn As Long, lJobReturn As Long
Dim bytFlags As Byte, bytDoW As Byte
Dim lJobid As Long, lptrCmd As Long, lTime As Long
If Left$(sComputer, 2) <> "\\" And Len(sComputer) > 0 Then
sComputer = "\\" & sComputer
End If
'Convert server and command to unicode, and Days of week/Flags to Byte
abytServer = sComputer & vbNullChar
abytCmd = sCommadLine & vbNullChar
bytDoW = eWeekDay
bytFlags = lFlags
'Convert Time to a long
lTime = zTimeToMilliseconds(Trim$(sTime))
'Allocate buffer space for command
lReturn = NetAPIBufferAllocate(UBound(abytCmd) + 1, lptrCmd)
'Set structure up
lReturn = StrToPtr(lptrCmd, abytCmd(0))
tInfo.dwJobTime = lTime
tInfo.dwDaysOfWeek = bytDoW
tInfo.dwFlags = bytFlags
tInfo.lptCommand = lptrCmd
'Add job
If NetScheduleJobAdd(abytServer(0), tInfo, lJobid) = 0 Then
'Suceeded in adding job
ServiceAddJob = True
End If
'Dealloc buffer
Call NetApiBufferFree(lptrCmd)
End Function
'Purpose : Converts a time to a time in milliseconds, from midnight.
'Inputs : sTime The time to convert, in the format hh:mm eg. 17:00 (five o'clock)
'Outputs : Returns The time in ms from
midnight
'Author : Andrew Baker
'Date : 18/01/2001 10:38
'Notes :
'Revisions :
'Assumptions :
Function zTimeToMilliseconds(sTime As String) As Long
zTimeToMilliseconds = ((Val(Left$(sTime, 2)) * 3600) + (Val(Right$(sTime, 2)) * 60)) * 1000
End Function
'Demonstration routine
Sub Test()
Dim asJobs() As String, lThisJob As Long
If ScheduleState <> 0 Then
'Schedule service not running
Debug.Print ScheduleServiceStart
End If
If ScheduleState = 0 Then
Dim CompName As String
CompName = Space(256)
Call GetComputerName(CompName, 256)
CompName = Trim(CompName)
CompName = Replace(CompName, Chr(0), "")
ServiceEnumJobs asJobs, CompName
For lThisJob = 1 To UBound(asJobs, 2)
Debug.Print "Command Line: " & asJobs(1, lThisJob)
Debug.Print "Time: " & asJobs(2, lThisJob)
Debug.Print "Day Info: " & asJobs(3, lThisJob)
Debug.Print "ID: " & asJobs(4, lThisJob)
Next
'If ServiceAddJob("16:00", dowFriday + dowThursday, "C:\home.exe") = True Then
'MsgBox "Added job"
'Else
'MsgBox "Failed to add job"
'End If
End If
End Sub
Private Sub Command1_Click()
Test
End Sub
|
