Solved

Schedule Task with VB

Posted on 2001-08-17
11
1,246 Views
Last Modified: 2010-01-19
I'm developing an app which needs to place itself on the list of scheduled tasks, using input from the user, such as start date/time, frequency, end date/time.  I would prefer not having the application running all the time and using a sleep function or long-duration timer.  We're talking intervals of several weeks.

Question:  how do I create/update/delete a scheduled task using VB?  Is there an API and object model I can access using VB?  Is there a reference I can set?

0
Comment
Question by:john_price
11 Comments
 
LVL 1

Expert Comment

by:zzconsumer
ID: 6397052
You may use the API call sleep (taken from API Text viewer):
Public Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

in your code, just write:
Sleep 604800000 ' Wait one week.

0
 
LVL 2

Expert Comment

by:PeteD
ID: 6397114
email me at mailto:pdobson@focus-solutions.co.uk and I'll reply with a sample app attatched
0
 
LVL 6

Expert Comment

by:sharmon
ID: 6397120
You can refer to this MSDN page for using Task Scheduler via command line, which should help you do this.

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/act/htm/actml_pro_schd.asp
0
 
LVL 4

Expert Comment

by:WolfgangKoenig
ID: 6397133
I don't think that you can use the sleep function because it handles only the execution of the current thread for a specified interval ...

The only way is to start your program when the system boot is done and check against the system time if the scheduled task should started ... When you checked this you can set an timer in your application to raise up the task when the time is over. (Therefore use an timer control ...)

Hope thats a good way for you ?

WoK
0
 
LVL 2

Expert Comment

by:PeteD
ID: 6397436
There is a better way! But its a hell of a lot of code!. h well here goes... you will have to add common dialog's, image views where apropriate!

******module code


' ++
' Project:  WinSched
' Author:   Andy Doran (andy.doran@dial.pipex.com)
' Date:     September 1998
' Abstract:
'
'           This VB project shows a few things relating to
'           Win32 API calls for service control and job
'           scheduling and enumeration of servers.
'
'           Service control is used to ensure the Schedule
'           service is running (or to start it). Job control
'           is used in eumerating then adding/deleting jobs.
'           Server enumaration is used to browse for another
'           computer.
'
'           This is an example only - not fully functional as yet.
'           Things to be aware of:-
'
'       1)  I do not interpret or set values for days of the
'           month (ie 1st, 2nd, 28th etc.) that a job can run
'           on. Just too lazy!
'
'       2)  I only interpret flags for Each and Next
'
'       3)  No real checking is done on the input of the
'           schedule time. What I want is a time in the form
'           hh:mm - so just enter it carefully!
'
' --
Option Explicit

'
' Constants
'

Global sComputerName As String
Global sDomain As String

Global Const SC_MANAGER_CONNECT = &H1
Global Const SC_MANAGER_CREATE_SERVICE = &H2
Global Const SC_MANAGER_ENUMERATE_SERVICE = &H4
Global Const SC_MANAGER_LOCK = &H8
Global Const SC_MANAGER_QUERY_LOCK_STATUS = &H10
Global Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20
Global 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

Global Const SERVICE_QUERY_CONFIG = &H1
Global Const SERVICE_CHANGE_CONFIG = &H2
Global Const SERVICE_QUERY_STATUS = &H4
Global Const SERVICE_ENUMERATE_DEPENDENTS = &H8
Global Const SERVICE_START = &H10
Global Const SERVICE_STOP = &H20
Global Const SERVICE_PAUSE_CONTINUE = &H40
Global Const SERVICE_INTERROGATE = &H80
Global Const SERVICE_USER_DEFINED_CONTROL = &H100
Global 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

Global Const SERVICE_STOPPED = 1
Global Const SERVICE_START_PENDING = 2
Global Const SERVICE_STOP_PENDING = 3
Global Const SERVICE_RUNNING = 4
Global Const SERVICE_CONTINUE_PENDING = 5
Global Const SERVICE_PAUSE_PENDING = 6
Global Const SERVICE_PAUSED = 7

Global Const SERVICE_BOOT_START = 0
Global Const SERVICE_SYSTEM_START = 1
Global Const SERVICE_AUTO_START = 2
Global Const SERVICE_DEMAND_START = 3
Global Const SERVICE_DISABLED = 4

Global Const SERVICE_CONTROL_STOP = 1
Global Const SERVICE_CONTROL_PAUSE = 2
Global Const SERVICE_CONTROL_CONTINUE = 3
Global Const SERVICE_CONTROL_INTERROGATE = 4
Global Const SERVICE_CONTROL_SHUTDOWN = 5

Global Const ERROR_MORE_DATA = 234
Global Const ERROR_ACCESS_DENIED = 5
Global Const ERROR_INVALID_HANDLE = 6
Global Const ERROR_PATH_NOT_FOUND = 3
Global Const ERROR_SERVICE_ALREADY_RUNNING = 1056
Global Const ERROR_DATABASE_LOCKED = 1055
Global Const ERROR_SERVICE_DEPENDENCY_DELETED = 1075
Global Const ERROR_SERVICE_DEPENDENCY_FAIL = 1068
Global Const ERROR_SERVICE_DISABLED = 1058
Global Const ERROR_SERVICE_LOGON_FAILED = 1069
Global Const ERROR_SERVICE_MARKED_FOR_DELETE = 1072
Global Const ERROR_SERVICE_NO_THREAD = 1054
Global Const ERROR_SERVICE_REQUEST_TIMEOUT = 1053
Global Const ERROR_SERVICE_DOES_NOT_EXIST = 1060
Global Const ERROR_SERVICE_CANNOT_ACCEPT_CONTROL = 1061
Global Const ERROR_SERVICE_NOT_ACTIVE = 1062
Global Const ERROR_SERVICE_SPECIFIC_ERROR = 1066
Global Const ERROR_SERVICE_START_HANG = 1070
Global Const ERROR_SERVICE_EXISTS = 1073
Global Const ERROR_SERVICE_NEVER_STARTED = 1077
Global Const ERROR_SERVICE_NOT_FOUND = 1243
Global Const ERROR_INSUFFICIENT_BUFFER = 122
Global Const ERROR_DATABASE_DOES_NOT_EXIST = 1065
Global Const ERROR_INVALID_PARAMETER = 87
Global Const ERROR_INVALID_NAME = 123

Global Const SERVICE_ACTIVE = &H1
Global Const SERVICE_INACTIVE = &H2
Global Const SERVICE_WIN32_OWN_PROCESS As Long = &H10
Global Const SERVICE_WIN32_SHARE_PROCESS As Long = &H20
Global Const SERVICE_WIN32 As Long = SERVICE_WIN32_OWN_PROCESS _
                  + SERVICE_WIN32_SHARE_PROCESS
 
Const JOB_RUN_PERIODICALLY = &H1
Const JOB_EXEC_ERROR = &H2
Const JOB_RUNS_TODAY = &H4
Const JOB_ADD_CURRENT_DATE = &H8
Const JOB_NONINTERACTIVE = &H10

'
' Type Declarations
'

Type AT_ENUM
    dw_JobId As Long
    dw_JobTime As Long
    dw_DaysOfMonth As Long
    dw_DaysOfWeek As Byte
    dw_Flags As Byte
    dw_dummy As Integer
    ptr_Command As Long
End Type

Type AT_INFO
    dw_JobTime As Long
    dw_DaysOfMonth As Long
    dw_DaysOfWeek As Byte
    dw_Flags As Byte
    dw_dummy As Integer
    ptr_Command As Long
End Type

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

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

Type ENUM_SERVICE_STATUS
    lpServiceName As Long
    lpDisplayName As Long
    ServiceStatus As SERVICE_STATUS
End Type

'
' Functions
'

Declare Function OpenSCManager _
    Lib "advapi32.dll" _
    Alias "OpenSCManagerA" ( _
    ByVal lpMachineName As String, _
    ByVal lpDatabaseName As String, _
    ByVal dwDesiredAccess As Long) As Long
   
Declare Function CloseServiceHandle _
    Lib "advapi32.dll" ( _
    ByVal hSCObject As Long) As Long

Declare Function OpenService _
    Lib "advapi32.dll" _
    Alias "OpenServiceA" ( _
    ByVal hSCManager As Long, _
    ByVal lpServiceName As String, _
    ByVal dwDesiredAccess As Long) As Long

Declare Function PtrToStr _
    Lib "Kernel32" _
    Alias "lstrcpyW" ( _
    RetVal As Byte, _
    ByVal Ptr As Long) As Long

Declare Function StrToPtr _
    Lib "Kernel32" _
    Alias "lstrcpyW" ( _
    ByVal Ptr As Long, _
    Source As Byte) As Long

Declare Function PtrToInt _
    Lib "Kernel32" _
    Alias "lstrcpynW" ( _
    RetVal As Any, _
    ByVal Ptr As Long, _
    ByVal nCharCount As Long) As Long

Declare Function StrLen _
    Lib "Kernel32" _
    Alias "lstrlenW" ( _
    ByVal Ptr As Long) As Long

Declare Function QueryServiceStatus _
    Lib "advapi32.dll" ( _
    ByVal hService As Long, _
    lpServiceStatus As Any) As Long

Declare Function StartService _
    Lib "advapi32.dll" _
    Alias "StartServiceA" ( _
    ByVal hService As Long, _
    ByVal dwNumServiceArgs As Long, _
    ByVal lpServiceArgVectors As Long) As Long

Declare Function QueryServiceConfig _
    Lib "advapi32.dll" _
    Alias "QueryServiceConfigA" ( _
    ByVal hService As Long, _
    lpServiceConfig As Any, _
    ByVal cbBufSize As Long, _
    pcbBytesNeeded As Long) As Long

Declare Function ControlService _
    Lib "advapi32.dll" ( _
    ByVal hService As Long, _
    ByVal dwControl As Long, _
    lpServiceStatus As Any) As Long

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
   
Declare Sub CopyMem Lib "Kernel32" _
    Alias "RtlMoveMemory" ( _
    pTo As Any, _
    uFrom As Any, _
    ByVal lSize As Long)
 
Declare Function NetScheduleJobGetInfo _
    Lib "netapi32" ( _
    Servername As Byte, _
    ByVal JobId As Long, _
    PointerToBuffer As Any) As Long

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

Declare Function NetScheduleJobDel _
    Lib "netapi32" ( _
    Servername As Byte, _
    ByVal MinJobId As Long, _
    ByVal MaxJobId As Long) As Long

Declare Function NetScheduleJobAdd _
    Lib "netapi32" ( _
    Servername As Byte, _
    PointerToBuffer As AT_INFO, _
    JobInfo As Long) As Long
   
Declare Function NetAPIBufferFree _
    Lib "netapi32.dll" _
    Alias "NetApiBufferFree" ( _
    ByVal Ptr As Long) As Long

Declare Function NetAPIBufferAllocate _
    Lib "netapi32.dll" _
    Alias "NetApiBufferAllocate" ( _
    ByVal ByteCount As Long, _
    Ptr As Long) As Long
   
   
Declare Function GetLastError _
    Lib "kernel32.dll" () As Long

Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Public Const LVM_FIRST = &H1000
Public Const LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54
Public Const LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 55

Public Const LVS_EX_FULLROWSELECT = &H20

' ++
' Function: GetScheduleInfo
' Action:   Return the state of the schedule service
' Input:    sComputer   -   Computer
' Output:   True/False
' --

Function GetScheduleInfo(sComputer As String) As Long

Dim lSCHandle As Long
Dim lSHandle As Long
Dim sState As String
Dim lReturn As Long


    GetScheduleInfo = False
   
'
' Connect to Service Control Manager
'

    lSCHandle = ConnectSCManager( _
        sComputer, _
        SC_MANAGER_CONNECT)
       
    If lSCHandle = False Then Exit Function
   
'
' Connect to Schedule service
'

    lSHandle = ConnectService( _
        lSCHandle, _
        "Schedule")
       
    If lSHandle = False Then Exit Function
   
'
' Get the service state
'

    sState = GetServiceState(lSHandle)
   
    If sState = "" Then
        MsgBox "Cannot determine the state of the Schedule service, program exiting", vbOKOnly + vbCritical
        Exit Function
    End If
   
    If sState = "Started" Then
        GetScheduleInfo = True
        Exit Function
    End If
   
    lReturn = CloseServiceHandle(lSHandle)
    lReturn = CloseServiceHandle(lSCHandle)
   
    frmMain.sbMain.Panels("Status").Text = "Schedule Service is Stopped"
    DoEvents
   
'
' Its stopped - ask to start it
'

    If MsgBox( _
        "The Schedule service is not running, start it (answering no will terminate the application)?" _
        , vbYesNo + vbQuestion) _
        <> vbYes Then Exit Function
   
'
' Reconnect to Service control manager and schedule service
' this time with enough rights to start it
'

    lSCHandle = ConnectSCManager( _
        sComputer, SC_MANAGER_ALL_ACCESS)
       
    If lSCHandle = False Then Exit Function
   
    lSHandle = ConnectService( _
        lSCHandle, _
        "Schedule")
       
    If lSHandle = False Then Exit Function
   
'
' Start the service
'

    lReturn = StartService(lSHandle, 0, 0)

    If lReturn = 0 Then
        MsgBox "Error " & _
            GetLastError & _
            " attempting to restart service"
    End If
   
'
' Wait for started
'

    frmMain.sbMain.Panels("Status").Text = "Waiting for Schedule Service to start..."
    DoEvents
   
    Do
        sState = GetServiceState(lSHandle)
        If sState = "Unknown" Then Exit Do
    Loop Until sState = "Started"
   
    If sState = "Started" Then _
        GetScheduleInfo = True

End Function

' ++
' Function: ConnectSCManager
' Action:   Connect to Service Control Manager
' Input:    sSystem     -   Server
'           lConnect    -   Long - how to connect (what access)
' Output:   Handle or False
' --

Private Function ConnectSCManager( _
    sSystem As String, _
    lConnect As Long) As Long


Dim lSCHandle As Long

'
' Try to connect to the remote Service Control Manager
'
   
    lSCHandle = OpenSCManager( _
        sSystem + vbNullString, _
        vbNullString, _
        lConnect)
   
    If lSCHandle = 0 Then
        ProcessError GetLastError, "Connecting to Service Control Manager"
        ConnectSCManager = False
    Else
        ConnectSCManager = lSCHandle
    End If
   
End Function
Private Sub ProcessError(lError, sAction)

'
' See what error was returned
'

    Select Case lError
    Case ERROR_ACCESS_DENIED
        MsgBox "Access denied, you may not have sufficient privileges", vbOKOnly + vbCritical, sAction
    Case ERROR_DATABASE_DOES_NOT_EXIST
        MsgBox "The database does not exist", vbOKOnly + vbCritical, sAction
    Case ERROR_INVALID_PARAMETER
        MsgBox "An invalid parameter was passed", vbOKOnly + vbCritical, sAction
       
    Case Else
        MsgBox "Unknown error number " & Str$(lError) & " encountered", vbOKOnly + vbCritical, sAction
    End Select
   
End Sub

' ++
' Function: GetStartState
' Action:   Find out what the startup state of a service is
' Input:    lHandle -   Handle to service
' Output:   String "Automatic" "Manual" etc.
' --

Private Function GetStartState( _
    lHandle As Long) As String

Dim pState() As QUERY_SERVICE_CONFIG
Dim lReturn As Long
Dim lBuffer As Long
Dim lBytesNeeded As Long
Dim lStructNeeded As Long

'
' Call first with not enough data
'

    lReturn = QueryServiceConfig( _
        lHandle, _
        ByVal &H0, _
        &H0, _
        lBytesNeeded)
       
    If GetLastError <> ERROR_INSUFFICIENT_BUFFER Then
        GetStartState = "Unknown"
        Exit Function
    End If
       
'
' Calculate the buffer sizes
'

    lStructNeeded = lBytesNeeded / Len(pState(0)) + 1
   
    ReDim pState(lStructNeeded - 1)
    lBuffer = lStructNeeded * Len(pState(0))
   
'
' Do the real call now
'

    lReturn = QueryServiceConfig( _
        lHandle, _
        pState(0), _
        lBuffer, _
        lBytesNeeded)
       
'
' get the info from pstate()
'

    Select Case pState(0).dwStartType
        Case SERVICE_BOOT_START
            GetStartState = "Boot"
        Case SERVICE_SYSTEM_START
            GetStartState = "System"
        Case SERVICE_AUTO_START
            GetStartState = "Automatic"
        Case SERVICE_DISABLED
            GetStartState = "Disabled"
        Case SERVICE_DEMAND_START
            GetStartState = "Manual"
        Case Else
            GetStartState = "Unknown"
    End Select

End Function

' ++
' Function: ConnectService
' Action:   Connect to a specific service
' Input:    lHandle     -   Handle to SCManager
'           ServiceName -   The service to connect to
' Output:   Handle or False
' --

Private Function ConnectService( _
    lHandle As Long, _
    ServiceName As String) As Long

Dim lSHandle As Long
Dim lReturn As Long


'
' Open the Service Name
'

    lSHandle = OpenService( _
        lHandle, _
        ServiceName, _
        SERVICE_ALL_ACCESS)

    If lSHandle = 0 Then
        MsgBox "Error " & Str$(GetLastError) & " connecting to service " & ServiceName, vbOKOnly + vbCritical
        lReturn = CloseServiceHandle(lHandle)
        ConnectService = False
    Else
        ConnectService = lSHandle
    End If

End Function

' ++
' Function: GetServiceState
' Action:   Find out what state a service is in
' Input:    lHandle -   Handle to the service
' Output    String "Started" "Stopped" "Paused"
' --

Function GetServiceState(lHandle As Long) As String

Dim pstatus As SERVICE_STATUS
Dim lReturn As Long

'
' Get the service state
'

    lReturn = QueryServiceStatus( _
        lHandle, _
        pstatus)

    If lReturn <> 1 Then
        MsgBox "Error " & Str$(GetLastError) & " querying the service"
        lReturn = CloseServiceHandle(lHandle)
        'lReturn = CloseServiceHandle(lSCHandle)
        GetServiceState = ""
    End If

    Select Case pstatus.dwCurrentState
    Case SERVICE_STOPPED
        GetServiceState = "Stopped"
    Case SERVICE_START_PENDING
        GetServiceState = "Start Pending"
    Case SERVICE_STOP_PENDING
        GetServiceState = "Stop Pending"
    Case SERVICE_RUNNING
        GetServiceState = "Started"
    Case SERVICE_CONTINUE_PENDING
        GetServiceState = "Continue Pending"
    Case SERVICE_PAUSE_PENDING
        GetServiceState = "Pause Pending"
    Case SERVICE_PAUSED
        GetServiceState = "Paused"
    Case Else
        GetServiceState = "Unknown"
    End Select


End Function

' ++
' Function: EnumJobs
' Action:   Enumerate all Jobs
' Input:    sComputer   -   Server
' Output:   True/False
' --

Function EnumJobs(sComputer As String) As Long


Dim aServer() As Byte
Dim aCommand(99) As Byte
Dim sCommand As String
Dim lReturn As Long
Dim ptrBuffer As AT_ENUM
Dim lBuffer As Long
Dim lResume As Long
Dim lEntriesRead As Long
Dim lTotalEntries As Long
Dim itmX As ListItem
Dim i As Long
Dim sTemp As String
Dim lTemp As Long
Dim lTempBuffer As Long
Dim lResult As Long
Dim sTime As String
Dim sDayInfo As String

    EnumJobs = False
   
'
' Convert server to unicode
'

    aServer() = sComputer & vbNullChar
    lResume = 0
   
    lReturn = NetScheduleJobEnum( _
        aServer(0), _
        lBuffer, _
        255, _
        lEntriesRead, _
        lTotalEntries, _
        lResume)
   
    lTempBuffer = lBuffer
   
'
' if lTempBuffer <> 0 then there are jobs
'

    If lTempBuffer <> 0 Then
        i = 1
        Do
   
'
' Dump info into AT_ENUM structure
'

            CopyMem ptrBuffer, _
                ByVal lTempBuffer, _
                Len(ptrBuffer)

'
' Job id is straightforward - put into lvJobs
'

            lTemp = ptrBuffer.dw_JobId
       
            Set itmX = frmMain.lvJobs.ListItems. _
                Add(, , Str$(lTemp))
       
'
' Command is a long pointer - need to convert to a string
'

            lTemp = ptrBuffer.ptr_Command
            lResult = PtrToStr( _
                aCommand(0), _
                lTemp)
            sCommand = Left( _
                aCommand, _
                StrLen(lTemp))
            itmX.SubItems(1) = sCommand
       
'
' Time is in milliseconds - must convert it
'

            sTime = ConvertTime(ptrBuffer.dw_JobTime)
            itmX.SubItems(3) = sTime

'
' Daysof week and month & flags must be interpreted
'

            sDayInfo = GetDayInfo( _
                ptrBuffer.dw_DaysOfMonth, _
                ptrBuffer.dw_DaysOfWeek, _
                ptrBuffer.dw_Flags)
           
           
            itmX.SubItems(2) = sDayInfo
            itmX.Icon = "Job"
            itmX.SmallIcon = "Job"
            i = i + 1
       
            lTempBuffer = _
                lTempBuffer + Len(ptrBuffer)
           
        Loop Until i > lTotalEntries
    End If
   
End Function
   
' ++
' Function: ConvertToBinary
' Action:   Convert a decimal to a binary string
' Input:    y   -   Decimal number
' Output:   String "010010010"
' --

Function ConvertToBinary(y As Long) As String

'
' This routine converts a decimal dumber to
' a binary string - the decimal number can
' be any number up to 32768

Dim lAns As Long, lNumber As Long
Dim sBinary As String
Dim x As Long

    x = Abs(y)
    sBinary = ""
'
' This is why the biggest number is 32768
'

    lNumber = 32768
   
'
' Loop around going through the number. Keep
' dividing by a multiple of 2 and using whats
' left over
'
    Do
   
 '
 ' Divide by a multiple of 2. Use \ as this
 ' returns an integer - should be 1 (is divisible)
 ' or 0 (is not divisible)
 '
 
        lAns = x \ lNumber
       
        If lAns = 1 Then
           
 '
 ' This means we put a bit in the binary string
 '
 
            sBinary = sBinary + "1"
           
 '
 ' Now use MOD to determine the remainder after the
 ' above division. We then use the remainder to
 ' continue the process.
 '
 
            x = x Mod lNumber
       
        Else
           
 '
 ' This means we put a 0 in the binary string
 '
 
            sBinary = sBinary + "0"
       
        End If
       
 '
 ' Now reduce the number we are dividing by (by
 ' dividing in half - next bit down!
 '
 
        lNumber = lNumber / 2
       
 '
 ' Check that we haven't gone too far (ie that the
 ' number we are dividing by is at least 1
 '
       
        If lNumber < 1 Then Exit Do
       
    Loop
   
    ConvertToBinary = sBinary
   
End Function

' ++
' Function: ConvertTime
' Action:   Convert Milliseconds (from midnight) to a real time
' Input:    lMSec   -   Milliseconds
' Output:   String "xx:xx:xx"
' --

Function ConvertTime(lMSec As Long) As String

Dim lSeconds As Long

    lSeconds = lMSec \ 1000
    ConvertTime = Format$( _
        DateAdd("s", lSeconds, "00:00"), "hh:mm:ss")
       
End Function

' ++
' Function: TimeToMilliseconds
' Action:   Convert time (12:22) to milliseconds from midnight
' Input:    sTime   -   Time
' Output:   Long (milliseconds from midnight)
' --

Function TimeToMilliseconds(sTime As String) As Long

    TimeToMilliseconds = ((Val(Left$(sTime, 2)) * 3600) + _
        (Val(Right$(sTime, 2)) * 60)) * 1000
       
End Function

' ++
' Function: GetDayInfo
' Action:   Interpret AT_ENUM to get schedule days
' Input:    lMonth  -   Days of month (as a long)
'           bDay    -   Days of week (as byte)
'           bFlag   -   Flags (as byte)
' Output:   Formatted ("Each Tue Thu")
'
' Note:     Currently DaysOfMonth NOT interpreted!
' For more info, see Win32API reference - AT_ENUM
' --

Function GetDayInfo( _
    lMonth As Long, _
    bDay As Byte, _
    bFlag As Byte) As String
   
Dim sMonth As String
Dim sDay As String
Dim sFlag As String
Dim sRun As String
Dim i As Long
Dim aDays(7) As String

    aDays(1) = "Mon"
    aDays(2) = "Tue"
    aDays(3) = "Wed"
    aDays(4) = "Thu"
    aDays(5) = "Fri"
    aDays(6) = "Sat"
    aDays(7) = "Sun"
   
'
' Get a binary string for each of the inputs
' This is because 1s and 0s are used to show the various
' flags & days that are used
' eg for bDay (converted to sDay)
'
'   0000001 = Sunday
'   0000010 = Saturday
'   0000011 = Saturday & Sunday
'

    sMonth = ConvertToBinary(lMonth)
    sDay = Right$(ConvertToBinary(Val(bDay)), 7)
    sFlag = Right$(ConvertToBinary(Val(bFlag)), 8)
   
'
' Interpret the binary string for Days
'

    sRun = ""
    For i = 7 To 1 Step -1
        If Mid$(sDay, i, 1) = "1" Then
            If sRun = "" Then
                sRun = aDays((7 - i) + 1)
            Else
                sRun = sRun + " " + aDays((7 - i) + 1)
            End If
        End If
    Next i
   
'
' Interpret flags - only ones used at present are Each and Next
'

    If Left$(sFlag, 1) = "1" Then
        sRun = "Next: " + sRun
    Else
        If Right$(sFlag, 1) = "1" Then
            sRun = "Each: " + sRun
        End If
    End If
           
    GetDayInfo = sRun
   
End Function

' ++
' Function: Mask
' Action:   Determine the outcome of a binary bitmask
' Input:    sHi -   Binary string
'           sLo -   Binary string (bitmask)
' Output:   binary string
' --

Function Mask(sHi, sLo) As String

Dim sTemp As String
Dim i As Long
Dim sHigh As String
Dim sLow As String

    sHigh = Right$(sHi, 7)
    sLow = Right$(sLo, 7)
   
    sTemp = ""
   
    For i = 1 To 7
   
        If Mid$(sHigh, i, 1) = "1" And _
            Mid$(sLow, i, 1) = "1" Then
            sTemp = sTemp + "1"
        Else
            sTemp = sTemp + "0"
        End If
    Next i
   
    Mask = sTemp
End Function

' ++
' Function: GetJobInfo
' Action:   Get full details for job
' Input:    sComputer   -   Server
'           lJob        -   Job id
' Output:   Nothing - just a message box at the moment
' --

Function GetJobInfo( _
    sComputer As String, _
    lJob As Long) As Long

Dim aServer() As Byte
Dim aCommand(99) As Byte
Dim sCommand As String
Dim lReturn As Long
Dim ptrBuffer As AT_INFO
Dim lBuffer As Long
Dim sTemp As String
Dim lTemp As Long
Dim lResult As Long
Dim sTime As String
Dim sDayInfo As String
   
    aServer() = sComputer & vbNullChar
   
    lReturn = NetScheduleJobGetInfo( _
        aServer(0), _
        lJob, _
        lBuffer)
   
    CopyMem ptrBuffer, _
        ByVal lBuffer, _
        Len(ptrBuffer)
       
        lTemp = ptrBuffer.ptr_Command
        lResult = PtrToStr( _
            aCommand(0), _
            lTemp)
        sCommand = Left( _
            aCommand, _
            StrLen(lTemp))
        sTime = ConvertTime(ptrBuffer.dw_JobTime)
       
        'sDayInfo = GetDayInfo( _
        '    ptrBuffer.dw_DaysOfMonth, _
        '    ptrBuffer.dw_DaysOfWeek, _
        '    ptrBuffer.dw_Flags)
       ' sDayInfo = Str$(ptrBuffer.dw_DaysOfMonth) + Chr$(13) + _
       '     Str$(ptrBuffer.uc_DaysOfWeek) + Chr$(13) + _
       '     Str$(ptrBuffer.uc_Flags)

    MsgBox sCommand + Chr$(13) + sTime + Chr$(13) + sDayInfo
   
End Function

' ++
' Function: DeleteJob
' Action:   Delete a job from the schedule
' Input:    sServer -   Server
'           lMin    -   Minimum Job id
'           lMax    -   Maximum Job id
' Output:   True/False
' --

Function DeleteJob( _
    sServer As String, _
    lMin As Long, _
    lMax As Long) As Long

Dim aServer() As Byte
Dim lReturn As Long

'
' Convert server to unicode
'

    aServer = sServer & vbNullChar
   
    lReturn = NetScheduleJobDel( _
        aServer(0), _
        lMin, _
        lMax)
       
    DeleteJob = lReturn = 0
   
End Function

'++
' Function: AddJob
' Action:   Add a job to the task scheduler
' Input:    sServer -   Server name
'           lTime   -   Time to submit job
'           lDom    -   Days of week (pre-formatted)
'           lDow    -   Days of week (pre-formatted)
'           lFlags  -   Flags (pre-formatted)
' Output:   True if ok
' --

Function AddJob( _
    sServer As String, _
    lTime As Long, _
    lDom As Long, _
    lDow As Long, _
    lFlags As Long, _
    sCmd) As Long

Dim aServer() As Byte
Dim lReturn As Long
Dim lJobReturn As Long
Dim bDoW As Byte
Dim bFlags As Byte
Dim tInfo As AT_INFO
Dim lJobid As Long
Dim lCmd As Long
Dim aCmd() As Byte
Dim lptr As Long
 
'
' Convert server and command to unicode, and Days of week/Flags to Byte
'

    aServer = sServer & vbNullChar
    aCmd = sCmd & vbNullChar
    bDoW = lDow
    bFlags = lFlags
   
'
' Allocate buffer space for command and turn to a long pointer
'

    lReturn = NetAPIBufferAllocate(UBound(aCmd) + 1, lCmd)
   
    lReturn = StrToPtr(lCmd, aCmd(0))
   
'
' Set up Job info structure
'

    tInfo.dw_JobTime = lTime
    tInfo.dw_DaysOfMonth = lDom
    tInfo.dw_DaysOfWeek = bDoW
    tInfo.dw_Flags = bFlags
    tInfo.ptr_Command = lCmd
       
'
' Make the call
'

    lJobReturn = NetScheduleJobAdd( _
        aServer(0), _
        tInfo, _
        lJobid)
   
   
'
' Clean up
'

    lReturn = NetAPIBufferFree(lCmd)
       
    AddJob = lJobReturn = 0
   
End Function



******Class code clsNetAPI.cls


'
' Module:   basNETAPI
' Created:  18th June 1998, by ASH
' Reason:   Hold Net* functions
'

'
' Constants
'

Private Const UNLEN = 256
Private Const PWLEN = 256
Private Const LM_UNLEN = 20
Private Const LM_PWLEN = 14

Private Const USER_PRIV_USER = 1

Private Const TIMEQ_FOREVER = -1
Private Const USER_MAX_STORAGE_UNLIMITED = -1

Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Private Const LANG_ENGLISH = &H9
Private Const SUBLANG_DEFAULT = &H1
Private Const SUBLANG_ENGLISH_UK = &H2
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100

Private Const UF_SCRIPT = &H1
Private Const UF_ACCOUNTDISABLE = &H2
Private Const UF_HOMEDIR_REQUIRED = &H8
Private Const UF_LOCKOUT = &H10
Private Const UF_PASSWD_NOTREQD = &H20
Private Const UF_PASSWD_CANT_CHANGE = &H40
Private Const UF_NORMAL_ACCOUNT = &H200

Private Const LOCKED_BIT = "1,3,5"
Private Const DISABLED_BIT = "2,3,A"
Private Const PDC_BIT = "8,9,A,B,F"
Private Const BDC_BIT = "1,3,5,7,9,D,F"
   
Private Const FILTER_NORMAL_ACCOUNT = &H2

Private Const WKSTA_LEVEL_100 = 100
Private Const SERVER_LEVEL_101 = 101
Private Const USER_LEVEL_2 = 2

Private Const SV_TYPE_WORKSTATION = &H1
Private Const SV_TYPE_SERVER = &H2
Private Const SV_TYPE_SQLSERVER = &H4
Private Const SV_TYPE_DOMAIN_CTRL = &H8
Private Const SV_TYPE_DOMAIN_BACKUP = &H10
Private Const SV_TYPE_TIMESOURCE = &H20
Private Const SV_TYPE_AFP = &H40
Private Const SV_TYPE_NOVELL = &H80
Private Const SV_TYPE_NT = &H8000
Private Const SV_TYPE_ALL = &HFFFFFFFF



'
' Type declarations
'

Private Type WKSTA_INFO_100
    dw_platform_id As Long
    ptr_computername As Long
    ptr_langroup As Long
    dw_ver_major As Long
    dw_ver_minor As Long
End Type

Private Type SERVER_INFO_101
    dw_platform_id As Long
    ptr_name As Long
    dw_ver_major As Long
    dw_ver_minor As Long
    dw_type As Long
    ptr_comment As Long
End Type

Private Type MungeLong
    x As Long
    Dummy As Integer
End Type

Private Type MungeInt
    xLo As Integer
    xHi As Integer
    Dummy As Integer
End Type

Private Type TUser0
    ptrName As Long
End Type

Private Type TUser1
    ptrName As Long
    ptrPassword As Long
    dwPasswordAge As Long
    dwPriv As Long
    ptrHomeDir As Long
    ptrComment As Long
    dwFlags As Long
    ptrScriptPath As Long
End Type

Private Type TUser20
    usri20_name As Long
    usri20_Full_name As Long
    usri20_Comment As Long
    usri20_flags As Long
    usri20_user_id As Long
End Type

Private Type GROUP_INFO_1
    grpi1_name As Long
    grpi1_comment As Long
End Type

Private Type LOCAL_GROUP_INFO_1
    lgrpi1_name As Long
    lgrpi1_comment As Long
End Type

Private Type USER_INFO_2
    ptr_name As Long
    ptr_password As Long
    dw_password_age As Long
    dw_priv As Long
    ptr_homedir As Long
    ptr_comment As Long
    dw_Flags As Long
    ptr_script_path As Long
    dw_auth_flags As Long
    ptr_full_name As Long
    ptr_usr_comment As Long
    ptr_parms As Long
    ptr_workstations As Long
    dw_last_logon As Long
    dw_last_logoff As Long
    dw_account_expires As Long
    dw_max_storage As Long
    dw_units_per_week As Long
    dw_logon_hours As Long
    dw_bad_password_count As Long
    dw_num_logons As Long
    ptr_logon_server As Long
    dw_country_code As Long
    dw_code_page As Long
End Type


'
' Functions
'

Private Declare Sub RtlMoveMemory _
    Lib "Kernel32" ( _
    dest As Any, _
    Vsrc As Any, _
    ByVal lSize&)

Private Declare Function NetServerEnum _
    Lib "netapi32.dll" ( _
    vServername As Any, _
    ByVal lLevel As Long, _
    vBufptr As Any, _
    lPrefmaxlen As Long, _
    lEntriesRead As Long, _
    lTotalEntries As Long, _
    vServerType As Any, _
    ByVal sDomain As String, _
    vResumeHandle As Any) As Long
   
Private Declare Function NetWkstaGetInfo100 _
    Lib "netapi32" _
    Alias "NetWkstaGetInfo" ( _
    Servername As Byte, _
    ByVal Level As Long, _
    bufptr As Any) As Long
   
Private Declare Function NetServerGetInfo _
    Lib "netapi32" ( _
    Servername As Byte, _
    ByVal Level As Long, _
    bufptr As Any) As Long
   
Private Declare Function NetuserGetInfo _
    Lib "netapi32" ( _
    Servername As Byte, _
    Username As Byte, _
    ByVal Level As Long, _
    bufptr As Any) As Long

Private Declare Sub lstrcpyW _
    Lib "Kernel32" ( _
    vDest As Any, _
    ByVal sSrc As Any)

Private Declare Function NetGetDCName _
    Lib "netapi32.dll" ( _
    Servername As Byte, _
    DomainName As Byte, _
    DCNPtr As Long) As Long

Private Declare Function NetAPIBufferFree _
    Lib "netapi32.dll" _
    Alias "NetApiBufferFree" ( _
    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 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 GetUserName _
    Lib "advapi32.dll" _
    Alias "GetUserNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long

Private Declare Function GetComputerName _
    Lib "Kernel32" _
    Alias "GetComputerNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long

Private Declare Function GetLastError _
    Lib "Kernel32" () As Long

Private Declare Function FormatMessage _
    Lib "Kernel32" _
    Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, _
    lpSource As Any, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    Arguments As Long) As Long

Private Declare Function NetUserAdd2 _
    Lib "netapi32.dll" _
    Alias "NetUserAdd" ( _
    Servername As Byte, _
    ByVal Level As Long, _
    Buffer As USER_INFO_2, _
    ParmError 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 NetUserEnum0 Lib "netapi32.dll" _
    Alias "NetUserEnum" ( _
    Servername As Byte, _
    ByVal Level As Long, _
    ByVal IFilter As Long, _
    Buffer As Long, _
    ByVal PrefMaxLen As Long, _
    EntriesRead As Long, _
    TotalEntries As Long, _
    ResumeHandle As Long) As Long

Private Declare Function NetUserGetInfo20 Lib "netapi32.dll" _
    Alias "NetUserGetInfo" ( _
    Servername As Byte, _
    Username As Byte, _
    ByVal Level As Long, _
    Buffer As Any) As Long

Private Declare Function NetGroupGetInfo1 Lib "netapi32.dll" _
    Alias "NetGroupGetInfo" ( _
    Servername As Byte, _
    GroupName As Byte, _
    ByVal Level As Long, _
    Buffer As Any) As Long

Private Declare Function NetLocalGroupGetInfo1 Lib "netapi32.dll" _
    Alias "NetLocalGroupGetInfo" ( _
    Servername As Byte, _
    GroupName As Byte, _
    ByVal Level As Long, _
    Buffer As Any) As Long

Private Declare Function NetGroupEnumUsers0 Lib "netapi32.dll" _
    Alias "NetGroupGetUsers" ( _
    Servername As Byte, _
    GroupName As Byte, _
    ByVal Level As Long, _
    Buffer As Long, _
    ByVal PrefMaxLen As Long, _
    Entries As Long, _
    TotalEntries As Long, _
    ResumeHandle As Long) As Long

Private Declare Function NetGroupEnum0 Lib "netapi32.dll" _
    Alias "NetGroupEnum" ( _
    Servername As Byte, _
    ByVal Level As Long, _
    Buffer As Long, _
    ByVal PrefMaxLen As Long, _
    EntriesRead As Long, _
    TotalEntries As Long, _
    ResumeHandle As Long) As Long

Private Declare Function NetLocalGroupEnum0 Lib "netapi32.dll" _
    Alias "NetLocalGroupEnum" ( _
    Servername As Byte, _
    ByVal Level As Long, _
    Buffer As Long, _
    ByVal PrefMaxLen As Long, _
    EntriesRead As Long, _
    TotalEntries As Long, _
    ResumeHandle As Long) As Long

Private Declare Function NetUserGetGroups0 Lib "netapi32.dll" _
    Alias "NetUserGetGroups" ( _
    Servername As Byte, _
    Username As Byte, _
    ByVal Level As Long, _
    Buffer As Long, _
    ByVal PrefMaxLen As Long, _
    EntriesRead As Long, _
    TotalEntries As Long) As Long

Private Declare Function NetUserGetLocalGroups0 Lib "netapi32.dll" _
    Alias "NetUserGetLocalGroups" ( _
    Servername As Byte, _
    Username As Byte, _
    ByVal Level As Long, _
    ByVal Flags As Long, _
    Buffer As Long, _
    ByVal PrefMaxLen As Long, _
    EntriesRead As Long, _
    TotalEntries As Long) As Long
   
Public Function GetDomainName() As String

'
' Determine the Domain name using NetWkstaGetInfo
'

Dim lReturn As Long
Dim lTemp As Long
Dim sTemp As String
Dim aDomain(99) As Byte
Dim aServer() As Byte
Dim lBuffPtr As Long
Dim ptrWksta As WKSTA_INFO_100

    GetDomainName = ""
   
    aServer = "" + vbNullChar
   
    lReturn = NetWkstaGetInfo100( _
        aServer(0), _
        WKSTA_LEVEL_100, _
        lBuffPtr)
       
    If lReturn <> 0 Then
        'MsgBox NetErrorMsg
        Exit Function
    End If
       
    CopyMem ptrWksta, _
        ByVal lBuffPtr, _
        Len(ptrWksta)
       
    lTemp = ptrWksta.ptr_langroup
   
    lReturn = PtrToStr( _
        aDomain(0), _
        lTemp)
       
    sTemp = Left( _
        aDomain, _
        StrLen(lTemp))

    GetDomainName = sTemp
   
End Function
Public Function GetServerComment( _
    sServer As String) As String

'
' Determine the server comment using
' NetServerGetInfo
'

Dim lReturn As Long
Dim lTemp As Long
Dim sTemp As String
Dim aComment(99) As Byte
Dim aServer() As Byte
Dim lBuffPtr As Long
Dim ptrServer As SERVER_INFO_101

    GetServerComment = ""
   
    aServer = sServer + vbNullChar
   
    lReturn = NetServerGetInfo( _
        aServer(0), _
        SERVER_LEVEL_101, _
        lBuffPtr)
       
    If lReturn <> 0 Then
        MsgBox NetErrorMsg
        Exit Function
    End If
       
    CopyMem ptrServer, _
        ByVal lBuffPtr, _
        Len(ptrServer)
       
    lTemp = ptrServer.ptr_comment
   
    lReturn = PtrToStr( _
        aComment(0), _
        lTemp)
       
    sTemp = Left( _
        aComment, _
        StrLen(lTemp))

    GetServerComment = sTemp
   
End Function
Public Function GetServerType( _
    sServer As String) As String

'
' Determine the server type using
' NetServerGetInfo
'

Dim lReturn As Long
Dim lTemp As Long
Dim sTemp As String
Dim aServer() As Byte
Dim lBuffPtr As Long
Dim ptrServer As SERVER_INFO_101

    GetServerType = ""
   
    aServer = sServer + vbNullChar
   
    lReturn = NetServerGetInfo( _
        aServer(0), _
        SERVER_LEVEL_101, _
        lBuffPtr)
       
    If lReturn <> 0 Then
        MsgBox NetErrorMsg
        Exit Function
    End If
       
    CopyMem ptrServer, _
        ByVal lBuffPtr, _
        Len(ptrServer)
       
    lTemp = ptrServer.dw_type
   
    sTemp = Hex$(lTemp)
    If Len(sTemp) > 1 Then
        sTemp = Right$(sTemp, 2)
        If InStr(BDC_BIT, Left$(sTemp, 1)) Then
            GetServerType = "Backup"
        End If
    End If

    sTemp = Hex$(lTemp)
    If Len(sTemp) > 0 Then
        sTemp = Right$(sTemp, 1)
        If InStr(PDC_BIT, sTemp) Then
            GetServerType = "Primary"
        End If
    End If
   
End Function
Public Function GetServerVersion( _
    sServer As String) As String

'
' Determine the server version using
' NetServerGetInfo
'

Dim lReturn As Long
Dim lTemp As Long
Dim sTemp As String
Dim aServer() As Byte
Dim lBuffPtr As Long
Dim ptrServer As SERVER_INFO_101

    GetServerVersion = ""
   
    aServer = sServer + vbNullChar
   
    lReturn = NetServerGetInfo( _
        aServer(0), _
        SERVER_LEVEL_101, _
        lBuffPtr)
       
    If lReturn <> 0 Then
        MsgBox NetErrorMsg
        Exit Function
    End If
       
    CopyMem ptrServer, _
        ByVal lBuffPtr, _
        Len(ptrServer)
       
    lTemp = ptrServer.dw_ver_major
   
    sTemp = "V " & Trim$(Str$(lTemp)) & "."
   
    lTemp = ptrServer.dw_ver_minor
   
    sTemp = sTemp & Trim$(Str$(lTemp))
   
    GetServerVersion = sTemp
   
End Function
Public Function GetLocalComputerName() As String

'
' Determine the Computer name using NetWkstaGetInfo
'

Dim lReturn As Long
Dim lTemp As Long
Dim sTemp As String
Dim aComputer(99) As Byte
Dim aServer() As Byte
Dim lBuffPtr As Long
Dim ptrWksta As WKSTA_INFO_100

    GetLocalComputerName = ""
   
    aServer = "" + vbNullChar
   
    lReturn = NetWkstaGetInfo100( _
        aServer(0), _
        WKSTA_LEVEL_100, _
        lBuffPtr)
       
    If lReturn <> 0 Then
        'MsgBox NetErrorMsg
        Exit Function
    End If
       
    CopyMem ptrWksta, _
        ByVal lBuffPtr, _
        Len(ptrWksta)
       
    lTemp = ptrWksta.ptr_computername
   
    lReturn = PtrToStr( _
        aComputer(0), _
        lTemp)
       
    sTemp = Left( _
        aComputer, _
        StrLen(lTemp))

    GetLocalComputerName = sTemp
   
End Function
Public Function GetPDCName( _
    sServer As String, _
    sDomain As String) As String

'
' Get the PDC name for the given domain
'

Dim lResult As Long
Dim sDCName As String
Dim lDCNPtr As Long
Dim DNArray() As Byte
Dim MNArray() As Byte
Dim DCNArray(100) As Byte

    GetPDCName = ""
   
    MNArray = sServer & vbNullChar
    DNArray = sDomain & vbNullChar
    lResult = NetGetDCName( _
        MNArray(0), _
        DNArray(0), _
        lDCNPtr)
   
    If lResult <> 0 Then
        'MsgBox "Error " & _
        'lResult & _
        '" obtaining the Domain controller for Domain " & _
        'sDomain, _
        'vbOKOnly + vbExclamation
        Exit Function
    End If
   
    lResult = PtrToStr(DCNArray(0), lDCNPtr)
    lResult = NetAPIBufferFree(lDCNPtr)
    sDCName = DCNArray()
    GetPDCName = sDCName

End Function

Public Function NetErrorMsg() As String

Dim lReturn As Long
Dim sTemp As String

    sTemp = Space$(255)
    lReturn = FormatMessage( _
        FORMAT_MESSAGE_ALLOCATE_BUFFER + _
        FORMAT_MESSAGE_FROM_STRING, _
        Null, _
        10, _
        LANG_ENGLISH + SUBLANG_ENGLISH_UK, _
        sTemp, _
        Len(sTemp), _
        0)
       
    sTemp = Mid$( _
        sTemp, 1, InStr( _
        sTemp, Chr$(0)) - 1)

    NetErrorMsg = sTemp
End Function
Public Function GetUserFullname( _
    ByVal sUser As String, _
    ByVal sServer As String) As String

Dim lResult As Long
Dim lBufPtr As Long
Dim UArray() As Byte
Dim SArray() As Byte
Dim aFullname(99) As Byte
Dim ptrBuff As TUser20
Dim sTemp As String
Dim lTemp As Long

    UArray = sUser & vbNullChar
    SArray = sServer & vbNullChar

    lResult = NetUserGetInfo20( _
        SArray(0), _
        UArray(0), _
        20, _
        lBufPtr)

    CopyMem ptrBuff, _
        ByVal lBufPtr, _
        Len(ptrBuff)

    lTemp = ptrBuff.usri20_Full_name
    lResult = PtrToStr( _
        aFullname(0), _
        lTemp)
    sTemp = Left( _
        aFullname, _
        StrLen(lTemp))
   
'    lResult = PtrToStr(sTemp, lTemp)
    lResult = NetAPIBufferFree(lTemp)
    GetUserFullname = sTemp
         
   
   
'    sTemp = Hex$(lTemp)
'    If Len(sTemp) > 1 Then
'        sTemp = Right$(sTemp, 2)
'        If InStr(LOCKED_BIT, Left$(sTemp, 1)) Then
'            MsgBox "User " & sUser & " is locked out"
'        End If
'    End If''

'    sTemp = Hex$(lTemp)
'    If Len(sTemp) > 0 Then
'        sTemp = Right$(sTemp, 1)
'        If InStr(DISABLED_BIT, sTemp) Then
'            MsgBox "User " & sUser & " is disabled"
'        End If
'    End If
End Function
Public Function GetLastLogon( _
    ByVal sUser As String, _
    ByVal sServer As String) As Long

Dim lResult As Long
Dim lBufPtr As Long
Dim UArray() As Byte
Dim SArray() As Byte
Dim ptrBuff As USER_INFO_2
Dim sTemp As String
Dim lTemp As Long
Dim lLocked As Long
Dim lDisabled As Long

    lDisabled = False
    lLocked = False
   
    UArray = sUser & vbNullChar
    SArray = sServer & vbNullChar

    lResult = NetUserGetInfo20( _
        SArray(0), _
        UArray(0), _
        USER_LEVEL_2, _
        lBufPtr)

    CopyMem ptrBuff, _
        ByVal lBufPtr, _
        Len(ptrBuff)

    lTemp = ptrBuff.dw_last_logon

    'If lTemp = 0 Then
    '    sTemp = ""
    'Else
    '    sTemp = FormatDate(lTemp)
    'End If
   
    GetLastLogon = lTemp
   
End Function

Public Function GetLastLogoff( _
    ByVal sUser As String, _
    ByVal sServer As String) As String

Dim lResult As Long
Dim lBufPtr As Long
Dim UArray() As Byte
Dim SArray() As Byte
Dim ptrBuff As USER_INFO_2
Dim sTemp As String
Dim lTemp As Long

    UArray = sUser & vbNullChar
    SArray = sServer & vbNullChar

    lResult = NetUserGetInfo20( _
        SArray(0), _
        UArray(0), _
        USER_LEVEL_2, _
        lBufPtr)

    CopyMem ptrBuff, _
        ByVal lBufPtr, _
        Len(ptrBuff)

    lTemp = ptrBuff.dw_last_logoff

    If lTemp = 0 Then
        GetLastLogoff = "<none>"
    Else
        GetLastLogoff = FormatDate(lTemp)
    End If
   
End Function
Function FormatDate(ldate As Long) As String

    FormatDate = Format$( _
        DateAdd( _
            "s", _
            ldate, _
            "1-jan-1970"), _
        "dd-mmm-yyyy hh:mm")
   
End Function
Public Function EnumerateUsersByDate( _
    ByVal SName As String, _
    ByVal GName As String, _
    ByVal lDays As Integer) As String

'
' If a group name is used, must be Global not local
'
' Buffer filled from left with pointers to user names
' filled from right:-
'
'   ptr1|ptr2|...|ptrn|<garbage>|strn|...|str2|str1

Dim lResult As Long
Dim lBufPtr As Long
Dim lEntriesRead As Long
Dim lTotalEntries As Long
Dim lResumehandle As Long
Dim lBufLen As Long
Dim SNArray() As Byte
Dim GNArray() As Byte
Dim UNArray(99) As Byte
Dim sUName As String
Dim i As Integer
Dim lUNPtr As Long
Dim TempPtr As MungeLong
Dim TempStr As MungeInt
Dim sLogon As String
Dim sUsers As String
Dim aUsers() As Byte
Dim sServers As String

    EnumerateUsersByDate = ""
    sServers = EnumerateServers( _
        SV_TYPE_DOMAIN_BACKUP)
       
    SNArray = SName & vbNullChar
    GNArray = GName & vbNullChar
    lBufLen = 255
    lResumehandle = 0
   
    Do
        If GName = "" Then
            lResult = NetUserEnum0( _
                SNArray(0), _
                0, _
                FILTER_NORMAL_ACCOUNT, _
                lBufPtr, _
                lBufLen, _
                lEntriesRead, _
                lTotalEntries, _
                lResumehandle)
        Else
            lResult = NetGroupEnumUsers0( _
                SNArray(0), _
                GNArray(0), _
                0, _
                lBufPtr, _
                lBufLen, _
                lEntriesRead, _
                lTotalEntries, _
                lResumehandle)
        End If
       
        'EnumerateUsers = lResult
       
        If lResult <> 0 And lResult <> 234 Then
            EnumerateUsersByDate = _
                "*** Error " + Str$(lResult)
            Exit Function
        End If
       
        For i = 1 To lEntriesRead
            lResult = PtrToInt( _
                TempStr.xLo, _
                lBufPtr + (i - 1) * 4, _
                2)
            lResult = PtrToInt( _
                TempStr.xHi, _
                lBufPtr + (i - 1) * 4 + 2, _
                2)
            LSet TempPtr = TempStr
            lResult = PtrToStr( _
                UNArray(0), _
                TempPtr.x)
            sUName = Left( _
                UNArray, _
                StrLen(TempPtr.x))
            If LoggedOnBefore(sUName, _
                SName, _
                sServers, _
                lDays) Then
                sUsers = sUsers + sUName + ","
            End If
        Next i
       
    Loop Until lEntriesRead = lTotalEntries
   
    lResult = NetAPIBufferFree(lBufPtr)
   
    EnumerateUsersByDate = sUsers
   
End Function
Public Function EnumerateLockedUsers( _
    ByVal SName As String, _
    ByVal GName As String) As String

'
' If a group name is used, must be Global not local
'
' Buffer filled from left with pointers to user names
' filled from right:-
'
'   ptr1|ptr2|...|ptrn|<garbage>|strn|...|str2|str1

Dim lResult As Long
Dim lBufPtr As Long
Dim lEntriesRead As Long
Dim lTotalEntries As Long
Dim lResumehandle As Long
Dim lBufLen As Long
Dim SNArray() As Byte
Dim GNArray() As Byte
Dim UNArray(99) As Byte
Dim sUName As String
Dim i As Integer
Dim lUNPtr As Long
Dim TempPtr As MungeLong
Dim TempStr As MungeInt
Dim sFullName As String
'Dim itmX As ListItem
Dim sLogon As String
Dim sUsers As String
Dim aUsers() As Byte


    EnumerateLockedUsers = ""
    SNArray = SName & vbNullChar
    GNArray = GName & vbNullChar
    lBufLen = 255
    lResumehandle = 0
   
    Do
        If GName = "" Then
            lResult = NetUserEnum0( _
                SNArray(0), _
                0, _
                FILTER_NORMAL_ACCOUNT, _
                lBufPtr, _
                lBufLen, _
                lEntriesRead, _
                lTotalEntries, _
                lResumehandle)
        Else
            lResult = NetGroupEnumUsers0( _
                SNArray(0), _
                GNArray(0), _
                0, _
                lBufPtr, _
                lBufLen, _
                lEntriesRead, _
                lTotalEntries, _
                lResumehandle)
        End If
       
        'EnumerateUsers = lResult
       
        If lResult <> 0 And lResult <> 234 Then
            MsgBox "Error " & lResult & _
                " enumerating user " & _
                lEntriesRead & " of " & _
                lTotalEntries, _
                vbOKOnly + vbExclamation
            If lResult = 2220 Then MsgBox _
                "There is no Global group " & _
                GName, _
                vbOKOnly + vbExclamation
            Exit Function
        End If
       
        For i = 1 To lEntriesRead
            lResult = PtrToInt( _
                TempStr.xLo, _
                lBufPtr + (i - 1) * 4, _
                2)
            lResult = PtrToInt( _
                TempStr.xHi, _
                lBufPtr + (i - 1) * 4 + 2, _
                2)
            LSet TempPtr = TempStr
            lResult = PtrToStr( _
                UNArray(0), _
                TempPtr.x)
            sUName = Left( _
                UNArray, _
                StrLen(TempPtr.x))
            If AccountIsLocked(sUName, SName) Then
                sUsers = sUsers + sUName + ","
            End If
        Next i
       
    Loop Until lEntriesRead = lTotalEntries
   
    lResult = NetAPIBufferFree(lBufPtr)
   
    EnumerateLockedUsers = sUsers
   
End Function
Public Function AccountIsLocked( _
    ByVal sUser As String, _
    ByVal sServer As String) As Long

Dim lResult As Long
Dim lBufPtr As Long
Dim UArray() As Byte
Dim SArray() As Byte
Dim aFullname(99) As Byte
Dim ptrBuff As TUser20
Dim sTemp As String
Dim lTemp As Long

    AccountIsLocked = False
    UArray = sUser & vbNullChar
    SArray = sServer & vbNullChar

    lResult = NetUserGetInfo20( _
        SArray(0), _
        UArray(0), _
        20, _
        lBufPtr)

    CopyMem ptrBuff, _
        ByVal lBufPtr, _
        Len(ptrBuff)

    lTemp = ptrBuff.usri20_flags

    sTemp = Hex$(lTemp)
    If Len(sTemp) > 1 Then
        sTemp = Right$(sTemp, 2)
        If InStr(LOCKED_BIT, Left$(sTemp, 1)) Then
            AccountIsLocked = True
        End If
    End If ''

'    sTemp = Hex$(lTemp)
'    If Len(sTemp) > 0 Then
'        sTemp = Right$(sTemp, 1)
'        If InStr(DISABLED_BIT, sTemp) Then
'            MsgBox "User " & sUser & " is disabled"
'        End If
'    End If

End Function
Public Function AccountIsDisabled( _
    ByVal sUser As String, _
    ByVal sServer As String) As Long

Dim lResult As Long
Dim lBufPtr As Long
Dim UArray() As Byte
Dim SArray() As Byte
Dim aFullname(99) As Byte
Dim ptrBuff As TUser20
Dim sTemp As String
Dim lTemp As Long

    AccountIsDisabled = False
    UArray = sUser & vbNullChar
    SArray = sServer & vbNullChar

    lResult = NetUserGetInfo20( _
        SArray(0), _
        UArray(0), _
        20, _
        lBufPtr)

    CopyMem ptrBuff, _
        ByVal lBufPtr, _
        Len(ptrBuff)

    lTemp = ptrBuff.usri20_flags

    sTemp = Hex$(lTemp)
   
'    If Len(sTemp) > 1 Then
'        sTemp = Right$(sTemp, 2)
'        If InStr(LOCKED_BIT, Left$(sTemp, 1)) Then
'            AccountIsLocked = True
'        End If
'    End If ''

    If Len(sTemp) > 0 Then
        sTemp = Right$(sTemp, 1)
        If InStr(DISABLED_BIT, sTemp) Then
            AccountIsDisabled = True
        End If
    End If

End Function
Public Function LoggedOnBefore( _
    ByVal sUser As String, _
    sPdc As String, _
    ByVal sServers As String, _
    ByVal ldate As Long) As Long
   
Dim lResult As Long
Dim sTemp As String
Dim lTemp As Long
Dim sServer As String
Dim lLogon As Long
Dim lOldLogon As Long
Dim lPos1 As Long
Dim lPos2 As Long
Dim lCount As Long
Dim sDate

    LoggedOnBefore = False

'
' try PDC first
'

    lOldLogon = GetLastLogon(sUser, sPdc)
    lLogon = lOldLogon
    If Trim$(sServers) = "" Then GoTo no_bdc
   
'
' Loop through all BDCs
'
   
    lPos1 = 1
    lPos2 = 0
    lCount = 0

'
' Get the list of users, and how many - also use this to see
' if the user is to be skipped
'

    Do

        lPos2 = InStr(lPos1, sServers, ",")
        sTemp = Mid$(slocked, lPos1, lPos2 - lPos1)

        lLogon = GetLastLogon(sUser, sTemp)
        If lLogon > lOldLogon Then lOldLogon = lLogon
       
        lPos1 = lPos2 + 1

    Loop Until lPos1 >= Len(sServers)

no_bdc:

    sDate = DateSerial(Format$(FormatDate(lLogon), "yyyy"), Format$(FormatDate(lLogon), "mm"), Format$(FormatDate(lLogon), "dd"))
    If sDate < DateSerial(Format$(Now, "yyyy"), Format$(Now, "mm"), Format$(Now, "dd") - lDays) Then
        LoggedOnBefore = True
    Else
        LoggedOnBefore = False
    End If
   
   
End Function
Public Function EnumerateServers( _
    ByVal lType As Long)

Dim lReturn As Long
Dim Server_Info As Long
Dim lEntries As Long
Dim lTotal As Long
Dim lMax As Long
Dim vResume As Variant
Dim tServer_info_101 As SERVER_INFO_101
Dim sServer As String
Dim sDomain As String
Dim lServerInfo101StructPtr As Long
Dim x As Long, i As Long
Dim bBuffer(512) As Byte
Dim sServerList As String

    EnumerateServers = ""
    sServerList = ""
    sServer = vbNullString
               
    lReturn = NetServerEnum( _
        ByVal 0&, _
        101, _
        Server_Info, _
        lMax, _
        lEntries, _
        lTotal, _
        ByVal lType, _
        sDomain, _
        vResume)
   
    If lReturn <> 0 Then
        Exit Function
    End If
       
    x = 1
    lServerInfo101StructPtr = Server_Info
   
    Do While x <= lTotal
   
        RtlMoveMemory _
            tServer_info_101, _
            ByVal lServerInfo101StructPtr, _
            Len(tServer_info_101)
       
        lstrcpyW bBuffer(0), _
            tServer_info_101.ptr_name
        i = 0
        Do While bBuffer(i) <> 0
            sServer = sServer & _
                Chr$(bBuffer(i))
            i = i + 2
        Loop
        sServerList = sServerList + sServer + ","
       
        sServer = ""
        x = x + 1
       
        lServerInfo101StructPtr = _
            lServerInfo101StructPtr + _
            Len(tServer_info_101)
       
    Loop
   
    lReturn = NetAPIBufferFree(Server_Info)
   
    EnumerateServers = sServerList

End Function


********* frmMain code  ( need a list view and 2 image lists)


' ++
' See basMain for explanation comments
' --

Option Explicit

Private Sub cmdAdd_Click()

Dim lReturn As String

'
' Show the 'Add' form and refresh lvJobs
'

    frmAdd.Show 1
    ClearLV
    lReturn = EnumJobs(sComputerName)
   
End Sub

Private Sub cmdDelete_Click()

Dim lIndex As Long
Dim lReturn As Long
Dim lMin As Long
Dim lMax As Long
   
'
' Delete the currently selected item
'

    On Error GoTo Nothing_Selected
   
    lIndex = Me.lvJobs.SelectedItem.Index
    lMin = Me.lvJobs.ListItems(lIndex)
    lMax = lMin
   
'
' Confirm that we really do want to delete this job
'

    If MsgBox( _
        "Delete Job " & Str$(lMin), _
        vbYesNo + vbQuestion) <> vbYes Then
        Exit Sub
    End If
   
    Me.MousePointer = vbHourglass
    Me.sbMain.Panels("Status").Text = _
        "Deleting Job " & Str$(lMin)
    DoEvents
   
'
' Delete the job and refresh lvJobs
'

    lReturn = DeleteJob(sComputerName, _
        lMin, _
        lMax)
       
    ClearLV
    lReturn = EnumJobs(sComputerName)
    Me.sbMain.Panels("Status").Text = "Ready"
    Me.MousePointer = vbNormal
    DoEvents
   
Nothing_Selected:

    On Error GoTo 0
   
End Sub

Private Sub cmdExit_Click()

    End
   
End Sub

Private Sub cmdServer_Click()

Dim lReturn As Long
   
'
' Show the 'Browse' form to select another server
'

    Me.MousePointer = vbHourglass
    ClearLV
    Me.sbMain.Panels("Status").Text = "Selecting Server"
    DoEvents
    frmBrowse.Show 1

'
' Get the Service info for the Schedule service
'

    Me.sbMain.Panels("Status").Text = "Checking Schedule Service status..."
    DoEvents
   
    If Not GetScheduleInfo(sComputerName) Then
        Screen.MousePointer = vbNormal
        End
    End If
   
    lReturn = EnumJobs(sComputerName)
   
    Screen.MousePointer = vbNormal
    Me.sbMain.Panels("Status").Text = "Ready"
    Me.lblServer.Caption = "Scheduled tasks for " & sComputerName & ":"
    Me.lvJobs.Refresh
    Me.MousePointer = vbNormal
   
   
End Sub

Private Sub Form_Load()

Dim lReturn As Long
Dim clsNet As clsNetAPI

    Me.Caption = "Windows Task Scheduler"
   
'
' Set up lvMain to allow whole line select
'

   Call SendMessageLong(Me.lvJobs.hwnd, _
                        LVM_SETEXTENDEDLISTVIEWSTYLE, _
                        LVS_EX_FULLROWSELECT, True)

'
' Initialize class module
'

    Set clsNet = New clsNetAPI
   
    Me.MousePointer = vbHourglass
   
'
' Get local computer name and domain name
'

    sComputerName = clsNet.GetLocalComputerName
    sDomain = clsNet.GetDomainName
   
    If sComputerName = "" Then
        Screen.MousePointer = vbNormal
        MsgBox "Cannot determine computer name, program will exit", vbOKCancel + vbCritical
        End
    End If
   
    Me.lblServer.Caption = "Scheduled tasks for " & sComputerName & ":"

'
' Set up lvJobs with relevant colums (must be report view)
'

    Me.lvJobs.ColumnHeaders. _
        Add , , "Job Id", (Me.lvJobs.Width * 1) / 12
    Me.lvJobs.ColumnHeaders. _
        Add , , "Task", (Me.lvJobs.Width * 4) / 12
    Me.lvJobs.ColumnHeaders. _
        Add , , "Day", (Me.lvJobs.Width * 4) / 12
    Me.lvJobs.ColumnHeaders. _
        Add , , "Time", (Me.lvJobs.Width * 2) / 12
    ' Set View property to Report.
    Me.lvJobs.View = lvwReport

    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    Me.Show
    DoEvents
   
'
' Get the Service info for the Schedule service
'

    Me.sbMain.Panels("Status").Text = "Checking Schedule Service status..."
    DoEvents
   
'
' Check that the schedule service is running
'

    If Not GetScheduleInfo(sComputerName) Then
        Me.MousePointer = vbNormal
        End
    End If

    Set clsNet = Nothing
    Me.cmdDelete.Enabled = False
   
'
' Enumerate scheduled tasks
'

    lReturn = EnumJobs(sComputerName)
   
    Me.MousePointer = vbNormal
   
    Me.sbMain.Panels("Status").Text = "Ready"
   
End Sub

Private Sub lvJobs_Click()
   
    Me.cmdDelete.Enabled = True
   
       
End Sub

Private Sub lvJobs_DblClick()

Dim lIndex As Long
Dim lJob As Long
Dim lReturn As Long

    lIndex = Me.lvJobs.SelectedItem.Index
    lJob = Val(Me.lvJobs.ListItems(lIndex).Text)
    lReturn = GetJobInfo(sComputerName, lJob)
   

End Sub

' ++
' Routine:  ClearLV
' Action:   Just clears everything from the list view control
' --

Sub ClearLV()

Dim lCount As Long
Dim lTotal As Long

    lTotal = Me.lvJobs.ListItems.Count
    If lTotal = 0 Then Exit Sub
    lCount = 1
    Do
       
        Me.lvJobs.ListItems.Remove 1
        lCount = lCount + 1
   
    Loop Until lCount > lTotal

End Sub

******* frmAdd code

Private Sub cmdBrowse_Click()

Dim sTemp As String

    On Error GoTo Err_Cancel
   
    Me.cdAdd.Filter = "Executable files |*.bat;*.com;*.exe;*.cmd|All Files |*.*"
    Me.cdAdd.FilterIndex = 1
    Me.cdAdd.ShowOpen
    sTemp = Me.cdAdd.FileName
   
    On Error Resume Next
   
    If sTemp = "" Then GoTo Err_Cancel
   
    If Dir$(sTemp) = "" Then
   
        MsgBox "Unable to locate the file " & sTemp, vbOKCancel + vbExclamation
        Exit Sub
       
    End If
   
    Me.txtTask.Text = sTemp
   
Err_Cancel:
 
   

End Sub

Private Sub cmdCancel_Click()

    Me.Hide
   
End Sub

Private Sub cmdOK_Click()

Dim lTime As Long
Dim lFlags As Long
Dim lDow As Long
Dim lDom As Long

    If Me.txtTask.Text = "" Then
        MsgBox "You must enter the task to be scheduled", vbOKCancel + vbExclamation
        Exit Sub
    End If
   
    If Me.txtTime.Text = "" Then
        MsgBox "You must enter a time to schedule the task at", vbOKOnly + vbExclamation
        Exit Sub
    End If
   
    lTime = TimeToMilliseconds(Trim$(Me.txtTime.Text))
   
'
' Days of week is a long made from calculating the
' check boxes
'

    lDow = ((Me.chkSunday.Value) * 64)
    lDow = lDow + ((Me.chkSaturday.Value) * 32)
    lDow = lDow + ((Me.chkFriday.Value) * 16)
    lDow = lDow + ((Me.chkThursday.Value) * 8)
    lDow = lDow + ((Me.chkWednesday.Value) * 4)
    lDow = lDow + ((Me.chkTuesday.Value) * 2)
    lDow = lDow + ((Me.chkMonday.Value) * 1)
   
    lFlags = 1
   
    lReturn = AddJob(sComputerName, _
        lTime, _
        0, _
        lDow, _
        lFlags, _
        Trim$(Me.txtTask.Text))
       
    Me.Hide
   
End Sub

Private Sub Form_Activate()

    With Me
   
        .Move (Screen.Width - .Width) \ 2, _
            (Screen.Height - .Height) \ 2
           
        .Caption = "Add New Job"
        .txtTask = ""
        .txtTime = ""
       
    End With
   
           
       
End Sub

Private Sub txtTime_KeyPress(KeyAscii As Integer)

    If KeyAscii = 8 Then Exit Sub
    If Chr$(KeyAscii) = ":" Then Exit Sub
    If KeyAscii >= 48 And KeyAscii <= 57 Then Exit Sub
    KeyAscii = 0
   
End Sub



******frmBrowse (need a listview)

Option Explicit

Private Const SV_TYPE_WORKSTATION = &H1
Private Const SV_TYPE_SERVER = &H2
Private Const SV_TYPE_SQLSERVER = &H4
Private Const SV_TYPE_DOMAIN_CTRL = &H8
Private Const SV_TYPE_DOMAIN_BACKUP = &H10
Private Const SV_TYPE_TIMESOURCE = &H20
Private Const SV_TYPE_AFP = &H40
Private Const SV_TYPE_NOVELL = &H80
Private Const SV_TYPE_NT = &H8000
Private Const SV_TYPE_ALL = &HFFFFFFFF

Private Sub cmdBrowse_Click()

Dim lReturn As Long
Dim sReturn As String
Dim clsNet As clsNetAPI
Dim lPos1 As Long
Dim lPos2 As Long
Dim lCount As Long
Dim sTemp As String
Dim itmX As ListItem

    Set clsNet = New clsNetAPI
    Me.MousePointer = vbHourglass
   
    Me.Width = Me.lvServers.Width + 600
    Me.Height = Me.lvServers.Height + _
        Me.txtServer.Height + 800
    Me.cmdDone.Enabled = True
    Me.lvServers.Visible = True
   
    sReturn = clsNet.EnumerateServers(SV_TYPE_ALL)

'
' For only a few servers
'
'
' sReturn is a comma separated string
'

    lPos1 = 1
    lPos2 = 0
    lCount = 0

'
' Get the list of users, and how many - also use this to see
' if the user is to be skipped
'

    Do

        lPos2 = InStr(lPos1, sReturn, ",")
        sTemp = Mid$( _
            sReturn, _
            lPos1, _
            lPos2 - _
            lPos1)
        If sTemp = "" Then Exit Do
        Set itmX = Me.lvServers.ListItems.Add _
            (, , sTemp)
        itmX.SubItems(1) = clsNet.GetServerType(sTemp)
        itmX.SubItems(2) = clsNet.GetServerComment(sTemp)
        itmX.SubItems(3) = clsNet.GetServerVersion(sTemp)
        DoEvents
        lPos1 = lPos2 + 1

    Loop Until lPos1 >= Len(sReturn)
    Me.MousePointer = vbNormal
    Set clsNet = Nothing
   

End Sub

Private Sub cmdDone_Click()

    sComputerName = Trim$(Me.txtServer.Text)
    Me.Hide
   
End Sub

Private Sub Form_Activate()
   
Dim lCount As Long
Dim lTotal As Long
   
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    Me.lvServers.Visible = False
    Me.txtServer.Text = sComputerName
    Me.cmdDone.Left = ( _
        Me.cmdBrowse.Left + _
        Me.cmdBrowse.Width + _
        60)
    Me.Width = ( _
        Me.Label1.Width + _
        Me.txtServer.Width + _
        Me.cmdBrowse.Width + _
        Me.cmdDone.Width + _
        600)
    Me.cmdDone.Top = Me.cmdBrowse.Top
   
    Me.Height = Me.txtServer.Height + 800
    Me.cmdDone.Enabled = True

    lTotal = Me.lvServers.ListItems.Count

    lCount = 1
    If lTotal < 1 Then Exit Sub
   
    Do
       
        Me.lvServers.ListItems.Remove 1
       
        'itmX.Selected = True
        'Set itmX = Me.lvJobs.ListItems.Remove lCount
        lCount = lCount + 1
   
    Loop Until lCount > lTotal
   

End Sub

Private Sub Form_Load()
   
   Call SendMessageLong(Me.lvServers.hwnd, _
                        LVM_SETEXTENDEDLISTVIEWSTYLE, _
                        LVS_EX_FULLROWSELECT, True)
    Me.Caption = "Select Server"
   
    Me.lvServers.ColumnHeaders. _
        Add , , "Server name", _
        (Me.lvServers.Width * 3) / 18
    Me.lvServers.ColumnHeaders. _
        Add , , "Server type", _
        (Me.lvServers.Width * 3) / 18
    Me.lvServers.ColumnHeaders. _
        Add , , "Server comment", _
        (Me.lvServers.Width * 7) / 18
    Me.lvServers.ColumnHeaders. _
        Add , , "Version", _
        (Me.lvServers.Width * 3) / 18
   
    Me.lvServers.View = lvwReport
   
End Sub

Private Sub lvServers_Click()

Dim lIndex As Long

    lIndex = Me.lvServers.SelectedItem.Index
    Me.txtServer.Text = Me.lvServers. _
        ListItems(lIndex).Text

End Sub



This works!  Good luck!

Cheers!

Pete



0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

by:john_price
ID: 6397602
Clarification:
Did not want to
1. require reboots since system may be runnining non-stop during interval.
2. keep the application running in memory, when a task scheduler function is in windows
  a full solution would then require a combination of both of these, neither of which is desired.
3. required the user manually schedule the app via the task scheduler wizard.

Want the app to shedule itself based upon the user preferences, then leave memory.  An example of this is BackupExec Pro.

This rules out all but PeteD's answer.  The code here is long (you don't lie, Pete), so it will take me a while to dig in to it and develop a good test based upon it.  How in the world did you ever come up with that?

Thanks, Pete.  I'll come back here later to accept or comment.  If that is indeed my answer, it appears you may have saved me more than a little work!

-- John Price
0
 

Author Comment

by:john_price
ID: 6397902
Pete,

Wow, that is some code.  I have a few questions about it though.

1.  I've added controls so that the program compiles, but could you send me the object portion of the form files or pictures of the forms?
That will help me with other labels, sizing and positioning, etc.
2.  in frmAdd.cmdOK_Click,
lReturn is not defined yet the following code is in the procedure.  I don't see any place where lReturn is used in the module.  Can you clarify?

++
   lReturn = AddJob(sComputerName, _
       lTime, _
       0, _
       lDow, _
       lFlags, _
       Trim$(Me.txtTask.Text))
++

3. in clsNetAPI.LoggedOnBefore,
slocked is not defined, yet used in the line:

++
sTemp = Mid$(slocked, lPos1, lPos2 - lPos1)
++

I don't find it anywhere else in the application.  Can you clarify?

4. in clsNetAPI.loggedOnBefore,
lDays is not defined, yet used in the code:

++
   If sDate < DateSerial(Format$(Now, "yyyy"), Format$(Now, "mm"),  Format$(Now, "dd") - lDays) Then
       LoggedOnBefore = True
   Else
       LoggedOnBefore = False
   End If
++

it appears as if the argument ldate for this procedure should actually be named ldays.  Correct?

5.  Anything else I should be aware of?

Thanks very much for this solution.  As I said, I'll come back here as soon as I get a chance to run through it and test it to accept or comment.

-- John
0
 
LVL 1

Accepted Solution

by:
Aaron_Young earned 200 total points
ID: 6400769

There's an excellent example of using the TaskScheduler from within VB by Edanmo Morcillo on his website:
   
http://www.domaindlx.com/e_morcillo/scripts/cod/default.asp?page=

It's a complete project and fairly well commented.

(I don't want points for someone else's work.)

Regards,

- Aaron.
0
 
LVL 2

Expert Comment

by:PeteD
ID: 6406578
John,

This is not my own code, I found it on the net, but as I said in my 1st comment, please save yourself the trouble of getting it to work by emailing me, and I'll reply with  
all the files zipped!!!

Cheers

Pete
0
 

Author Comment

by:john_price
ID: 6406903
Aaron

That appears to be exactly what I need and more.  You may not have written it, but you pointed me to it, and that is worth the points.  Thanks.

Pete, Your solution looks like it would work too, but would require a few minor fixes or the exchange of those zip files.  The Edanamo Morcillo solution is pretty darn elegent.  Thanks for your response.
0
 

Expert Comment

by:jkruijt
ID: 26349220
Hello,
I'm looking for the same solution only the link in the answer is dead (http://www.domaindlx.com/e_morcillo/scripts/cod/default.asp?page=). Is there someone who has saved the page which contains this solution?
regards,
John
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

746 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now