Creating NT Service using VB [Archive]

matthias mueller

December 3rd, 1999, 08:20 AM

Hi,
try this code. It's official code from Microsoft.
Do not be konfused about my german remarks

Matthias

[vbcode]
Option Explicit

Private Const SERVICE_WIN32_OWN_PROCESS = &H10&
Private Const SERVICE_WIN32_SHARE_PROCESS = &H20&
Private Const SERVICE_WIN32 = SERVICE_WIN32_OWN_PROCESS + _
SERVICE_WIN32_SHARE_PROCESS

Private Const SERVICE_ACCEPT_STOP = &H1
Private Const SERVICE_ACCEPT_PAUSE_CONTINUE = &H2
Private Const SERVICE_ACCEPT_SHUTDOWN = &H4

Private Const SC_MANAGER_CONNECT = &H1
Private Const SC_MANAGER_CREATE_SERVICE = &H2
Private Const SC_MANAGER_ENUMERATE_SERVICE = &H4
Private Const SC_MANAGER_LOCK = &H8
Private Const SC_MANAGER_QUERY_LOCK_STATUS = &H10
Private Const SC_MANAGER_MODIFY_BOOT_CONFIG = &H20

Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SERVICE_QUERY_CONFIG = &H1
Private Const SERVICE_CHANGE_CONFIG = &H2
Private Const SERVICE_QUERY_STATUS = &H4
Private Const SERVICE_ENUMERATE_DEPENDENTS = &H8
Private Const SERVICE_START = &H10
Private Const SERVICE_STOP = &H20
Private Const SERVICE_PAUSE_CONTINUE = &H40
Private Const SERVICE_INTERROGATE = &H80
Private Const SERVICE_USER_DEFINED_CONTROL = &H100
Private Const SERVICE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
SERVICE_QUERY_CONFIG Or _
SERVICE_CHANGE_CONFIG Or _
SERVICE_QUERY_STATUS Or _
SERVICE_ENUMERATE_DEPENDENTS Or _
SERVICE_START Or _
SERVICE_STOP Or _
SERVICE_PAUSE_CONTINUE Or _
SERVICE_INTERROGATE Or _
SERVICE_USER_DEFINED_CONTROL)

Private Const SERVICE_DEMAND_START As Long = &H3

Private Const SERVICE_ERROR_NORMAL As Long = &H1

Private Enum SERVICE_CONTROL
SERVICE_CONTROL_STOP = &H1
SERVICE_CONTROL_PAUSE = &H2
SERVICE_CONTROL_CONTINUE = &H3
SERVICE_CONTROL_INTERROGATE = &H4
SERVICE_CONTROL_SHUTDOWN = &H5
End Enum

Private Enum SERVICE_STATE 'Status eines Services :
SERVICE_STOPPED = &H1 ' gestoppt
SERVICE_START_PENDING = &H2 ' ... wird versucht Service XYZ auf ABC zu starten
SERVICE_STOP_PENDING = &H3 ' ... wird versucht Service XYZ auf ABC zu beenden
SERVICE_RUNNING = &H4 ' gestartet
SERVICE_CONTINUE_PENDING = &H5 ' ... wird versucht Service XYZ auf ABC forzusetzen
SERVICE_PAUSE_PENDING = &H6 ' ... wird versucht Service XYZ auf ABC anzuhalten
SERVICE_PAUSED = &H7 ' angehalten
End Enum

Private Type SERVICE_TABLE_ENTRY
lpServiceName As String
lpServiceProc As Long
lpServiceNameNull As Long
lpServiceProcNull 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 Declare Function StartServiceCtrlDispatcher _
Lib "advapi32.dll" Alias "StartServiceCtrlDispatcherA" _
(lpServiceStartTable As SERVICE_TABLE_ENTRY) As Long
Private Declare Function RegisterServiceCtrlHandler _
Lib "advapi32.dll" Alias "RegisterServiceCtrlHandlerA" _
(ByVal lpServiceName As String, ByVal lpHandlerProc As Long) _
As Long
Private Declare Function SetServiceStatus _
Lib "advapi32.dll" (ByVal hServiceStatus As Long, _
lpServiceStatus As SERVICE_STATUS) As Long
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 CreateService _
Lib "advapi32.dll" Alias "CreateServiceA" _
(ByVal hSCManager As Long, ByVal lpServiceName As String, _
ByVal lpDisplayName As String, ByVal dwDesiredAccess As Long, _
ByVal dwServiceType As Long, ByVal dwStartType As Long, _
ByVal dwErrorControl As Long, ByVal lpBinaryPathName As String, _
ByVal lpLoadOrderGroup As String, ByVal lpdwTagId As String, _
ByVal lpDependencies As String, ByVal lp As String, _
ByVal lpPassword As String) As Long
Private Declare Function DeleteService _
Lib "advapi32.dll" (ByVal hService 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

'** Change SERVICE_NAME as needed
Private Const SERVICE_NAME As String = "MyService"

Private hServiceStatus As Long ' Handle auf den ServiceStatus
Private ServiceStatus As SERVICE_STATUS ' Strukturvariable ServiceStatus

Sub Main()
Dim hSCManager As Long ' Handle auf den ServiceManager
Dim hService As Long ' Handle auf den Service
Dim ServiceTableEntry As SERVICE_TABLE_ENTRY 'Typ Service Tabellen Eintrag
Dim b As Boolean ' nimmt Rückgabewerte von API-Funktionen auf
Dim cmd As String ' nimmt Parameter beim Programmaufruf aus der Kommandozeile auf

cmd = Trim(LCase(Command()))
Select Case cmd
Case "install" 'Install service on machine
hSCManager = OpenSCManager(vbNullString, vbNullString, _
SC_MANAGER_CREATE_SERVICE) ' Öffnet den ServiceManager und
' liefert Handle darauf zurück
hService = CreateService(hSCManager, SERVICE_NAME, _
SERVICE_NAME, SERVICE_ALL_ACCESS, _
SERVICE_WIN32_OWN_PROCESS, _
SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL, _
App.Path & "\" & App.EXEName, vbNullString, _
vbNullString, vbNullString, vbNullString, _
vbNullString) ' Erstellt den eigenlichen Dienst
' und liefert Handle darauf zurück

CloseServiceHandle hService ' Schließt den ServiceHandle wieder
CloseServiceHandle hSCManager ' " " " "

Case "uninstall" 'Remove service from machine
hSCManager = OpenSCManager(vbNullString, vbNullString, _
SC_MANAGER_CREATE_SERVICE) ' Öffnet den ServiceManager und
' liefert Handle darauf zurück
hService = OpenService(hSCManager, SERVICE_NAME, _
SERVICE_ALL_ACCESS) ' Öffnet Service

DeleteService hService ' Löscht Service
CloseServiceHandle hService ' Schließt den ServiceHandle wieder
CloseServiceHandle hSCManager ' Schließt den ServiceHandle wieder

Case Else 'Start the service
ServiceTableEntry.lpServiceName = SERVICE_NAME ' übergibt der Strukturvariablen
' 'ServiceTableEntry' den Service Namen
ServiceTableEntry.lpServiceProc = _
FncPtr(AddressOf ServiceMain) ' übergibt der Strukturvariablen
' 'ServiceTableEntry' den Service Namen
b = StartServiceCtrlDispatcher(ServiceTableEntry) ' Startet Service mit Inhalt der Strukturvariablen
' 'ServiceTableEntry'
End Select
End Sub

' Hauptprozedur des Services
Sub ServiceMain(ByVal dwArgc As Long, ByVal lpszArgv As Long)
Dim b As Boolean

'Set initial state
ServiceStatus.dwServiceType = SERVICE_WIN32_OWN_PROCESS ' Der Service erhält einen eigenen Prozeß
ServiceStatus.dwCurrentState = SERVICE_START_PENDING ' Status auf: ... wird versucht zu starten...
ServiceStatus.dwControlsAccepted = SERVICE_ACCEPT_STOP _
Or SERVICE_ACCEPT_PAUSE_CONTINUE _
Or SERVICE_ACCEPT_SHUTDOWN ' Legt fest, welche Tasten für den Service
' im ServiceControlManager aktiviert sind
ServiceStatus.dwWin32ExitCode = 0 ' ???
ServiceStatus.dwServiceSpecificExitCode = 0 ' ???
ServiceStatus.dwCheckPoint = 0 ' ???
ServiceStatus.dwWaitHint = 0 ' ???

hServiceStatus = RegisterServiceCtrlHandler(SERVICE_NAME, _
AddressOf Handler) ' Registriert den Service mit Namen und
' der Einsprungadresse der Handler-Prozedur
ServiceStatus.dwCurrentState = SERVICE_START_PENDING ' Status auf: ... wird versucht zu starten...
b = SetServiceStatus(hServiceStatus, ServiceStatus) ' aktualisiert den ServiceStatus im SC-Fenster
' mit Hilfe dessen Handles und der Strukturvariablen

'** Do Initialization Here

ServiceStatus.dwCurrentState = SERVICE_RUNNING
b = SetServiceStatus(hServiceStatus, ServiceStatus)

'** Perform tasks -- if none exit

''** If an error occurs the following should be used for shutting
''** down:
'' SetServerStatus SERVICE_STOP_PENDING
'' Clean up
'' SetServerStatus SERVICE_STOPPED
End Sub

Sub Handler(ByVal fdwControl As Long)
Dim b As Boolean

Select Case fdwControl
Case SERVICE_CONTROL_PAUSE
'** Do whatever it takes to pause here.
ServiceStatus.dwCurrentState = SERVICE_PAUSED
Case SERVICE_CONTROL_CONTINUE
'** Do whatever it takes to continue here.
ServiceStatus.dwCurrentState = SERVICE_RUNNING
Case SERVICE_CONTROL_STOP
ServiceStatus.dwWin32ExitCode = 0
ServiceStatus.dwCurrentState = SERVICE_STOP_PENDING
ServiceStatus.dwCheckPoint = 0
ServiceStatus.dwWaitHint = 0 'Might want a time estimate
b = SetServiceStatus(hServiceStatus, ServiceStatus)
'** Do whatever it takes to stop here.
ServiceStatus.dwCurrentState = SERVICE_STOPPED
Case SERVICE_CONTROL_INTERROGATE
'Fall through to send current status.
Case Else
End Select
'Send current status.
b = SetServiceStatus(hServiceStatus, ServiceStatus)
End Sub

Function FncPtr(ByVal fnp As Long) As Long ' Wandelt Handle der 'ServiceMain' Prozedur in ByVal Wert um
FncPtr = fnp
End Function

[/vbcode}