Full source of Service Program

‘Please Include Reference in your program
‘ VB-friendly NT Service API Functions
‘******************************************************************************
‘Module   :
‘Service Name :     frmService
‘Database   :
‘Created By :     C. Raghuraja, India
‘Created Date         :     05-Jan-2005
‘Description :     Service Source Program
‘******************************************************************************
Option Explicit
‘******************************************************************************

     ‘————————————————————————
     ‘ Win API 関数
     ‘————————————————————————
     Private Declare Function CreateThread Lib “kernel32″ (ByVal lpThreadAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
     Private Declare Function GetVersionEx Lib “kernel32″ Alias “GetVersionExA” (lpVersionInformation As OSVERSIONINFO) As Long
     Private Declare Function MessageBox Lib “user32″ Alias “MessageBoxA” (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

     Private Type OSVERSIONINFO
         dwOSVersionInfoSize As Long
         dwMajorVersion As Long
         dwMinorVersion As Long
         dwBuildNumber As Long
         dwPlatformId As Long
         szCSDVersion(1 To 128) As Byte                                       ‘Maintenance string for PSS usage
     End Type

     Private Const VER_PLATFORM_WIN32_NT = 2&
     Private Const INFINITE = -1&                                             ‘Infinite timeout
     Private Const WAIT_TIMEOUT = 258&
     Private ServiceStatus        As SERVICE_STATUS
     Private hServiceStatus       As Long

     Dim hStopEvent               As Long
     Dim hStartEvent              As Long
     Dim hStopPendingEvent
     Dim IsNT                     As Boolean
     Dim IsNTService              As Boolean
     Dim ServiceName()            As Byte
     Dim ServiceNamePtr           As Long

     ‘Service Name
     Private Const Service_Name   As String = “My Testing Service”
‘******************************************************************************
Public Sub fnSERVICE()
     On Error GoTo LOCALERRORHANDLER

     ‘ ===== SERVICE WILL START FROM HERE =====

     Dim hnd         As Long
     Dim h(0 To 1)   As Long

     ‘ Only one instance
     If App.PrevInstance Then Exit Sub

     ‘ Check OS type
     IsNT = CheckIsNT()

     ‘ Creating events
     hStopEvent = CreateEvent(0, 1, 0, vbNullString)
     hStopPendingEvent = CreateEvent(0, 1, 0, vbNullString)
     hStartEvent = CreateEvent(0, 1, 0, vbNullString)
     ServiceName = StrConv(Service_Name, vbFromUnicode)
     ServiceNamePtr = VarPtr(ServiceName(LBound(ServiceName)))

     If IsNT Then

         ‘Trying to start service
         hnd = StartAsService
         h(0) = hnd
         h(1) = hStartEvent

         ‘Waiting for one of two events: sucsessful service start (1) or Terminaton of service thread (0)

         IsNTService = WaitForMultipleObjects(2&, h(0), 0&, INFINITE) = 1&

         If Not IsNTService Then
             CloseHandle hnd
             MessageBox “Service program must be started as a service.”,”Service”
         End If

     Else

        MessageBox “Service program is only for Windows NT/2000/XP.”,”Service”

     End If

‘****************************************************************************************************************

     If IsNTService Then

         SetServiceState SERVICE_RUNNING

         ‘   ———   From Here Service Will Run   ———-

         Do

             ‘———————————————————
             ‘From Here What ever code writes will File in the Service Program
             ‘———————————————————

‘Please write your Code to Fire as Service
MessageBox “Service is Running”,”Service”

             ‘———————————————————
             ‘Sleep for given amount of minutes (60000 = 1 Minute)
             ‘You can Increase / Decrease
             ‘———————————————————

         Loop While WaitForSingleObject(hStopPendingEvent, 60000) = WAIT_TIMEOUT

         ‘ Here you may stop and destroy service’s objects
         SetServiceState SERVICE_STOPPED

         SetEvent hStopEvent

         ‘ Waiting for service thread termination
         WaitForSingleObject hnd, INFINITE
         CloseHandle hnd

     End If

     CloseHandle hStopEvent
     CloseHandle hStartEvent
     CloseHandle hStopPendingEvent

     ‘To Write message to Log File
    MessageBox “Service has Stopped”,”Service”

     Exit Sub
LOCALERRORHANDLER:
     Call fnERRLOG(”Error Occured:” & Err.Number & “:” & Err.Description)
End Sub
‘******************************************************************************
‘ CheckIsNT() returns True, if the program runs
‘ under Windows NT or Windows 2000, and False
‘ otherwise.
Private Function CheckIsNT() As Boolean
     Dim OSVer As OSVERSIONINFO
     OSVer.dwOSVersionInfoSize = LenB(OSVer)
     GetVersionEx OSVer
     CheckIsNT = OSVer.dwPlatformId = VER_PLATFORM_WIN32_NT
End Function
‘******************************************************************************
‘ The FncPtr function returns function pointer.
Private Function FncPtr(ByVal fnp As Long) As Long
     FncPtr = fnp
End Function
‘******************************************************************************
‘ The StartAsService function creates Service Dispatcher thread.
Private Function StartAsService() As Long
     Dim ThreadId As Long
     StartAsService = CreateThread(0&, 0&, AddressOf ServiceThread, 0&, 0&, ThreadId)
End Function
‘******************************************************************************
‘ The ServiceThread sub starts the service.
‘ This sub returns control only after service termination.
Private Sub ServiceThread(ByVal dummy As Long)
     Dim ServiceTableEntry As SERVICE_TABLE
     ServiceTableEntry.lpServiceName = ServiceNamePtr
     ServiceTableEntry.lpServiceProc = FncPtr(AddressOf ServiceMain)
     StartServiceCtrlDispatcher ServiceTableEntry
End Sub
‘******************************************************************************
‘ The ServiceMain sub - main service sub.
‘ It initializes service,
‘ sets event hStartEvent, and waits hStopEvent event.
‘ When hStopEvent fires, this sub exits and service stops.
Private Sub ServiceMain(ByVal dwArgc As Long, ByVal lpszArgv As Long)
     ServiceStatus.dwServiceType = SERVICE_WIN32_OWN_PROCESS
     ServiceStatus.dwControlsAccepted = SERVICE_ACCEPT_STOP _
                                     Or SERVICE_ACCEPT_SHUTDOWN
     ServiceStatus.dwWin32ExitCode = 0&
     ServiceStatus.dwServiceSpecificExitCode = 0&
     ServiceStatus.dwCheckPoint = 0&
     ServiceStatus.dwWaitHint = 0&
     hServiceStatus = RegisterServiceCtrlHandler(Service_Name, _
                            AddressOf Handler)
     SetServiceState SERVICE_START_PENDING
     ‘ Set hStartEvent. It unlocks main application thread
     ‘ which allows to do some work in it
     SetEvent hStartEvent
     ‘ Wait until hStopEvent fires
     WaitForSingleObject hStopEvent, INFINITE
End Sub
‘******************************************************************************
‘ The Handler sub processes commands from Service Dispatcher.
‘ It sets event hStopEvent when processes command
‘ SERVICE_CONTROL_STOP or SERVICE_CONTROL_SHUTDOWN.
Private Sub Handler(ByVal fdwControl As Long)
     Select Case fdwControl
         Case SERVICE_CONTROL_SHUTDOWN, SERVICE_CONTROL_STOP
             SetServiceState SERVICE_STOP_PENDING
             SetEvent hStopPendingEvent
         Case Else
             SetServiceState
     End Select
End Sub
‘******************************************************************************
‘ The SetServiceState sub changes service state.
‘ If parameter omitted, it confirms previous state.
Private Sub SetServiceState(Optional ByVal NewState As SERVICE_STATE = 0&)
     If NewState <> 0& Then ServiceStatus.dwCurrentState = NewState
     SetServiceStatus hServiceStatus, ServiceStatus
End Sub
‘******************************************************************************