by Raghuraja. C (India) (1 Submission)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 18th February 2005
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Full source of Service Program
API Declarations
' VB-friendly NT Service API Functions
VBcoders
'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