Windows Service code example in VB.Net

A VB.Net Windows service code example with stand-alone compilation and installation scripts. The service contains a simple scheduler, enabling it to perform an arbitrary task you write yourself at configurable intervals.

Download example code package

Instructions for editing, compiling and installing service:
  1. Rename TestService.vb and TestService.exe.config to <YourServiceName>.vb and <YourServiceName>.exe.config (no spaces in the name, please)
  2. Do a search/replace on all instances of the string "TestService" in <YourServiceName>.vb to name your service. Use the same <YourServiceName> as in step 1
  3. Set the service process account (Me.ServiceProcessInstaller1.Account) to either "ServiceAccount.NetworkService", "ServiceAccount.LocalService", "ServiceAccount.LocalSystem" or "ServiceAccount.User" according to your security design. Note that the NetworkService and LocalService accounts may need explicit read/execute NTFS permissions on the folder containing the service files for the service to be allowed to start
  4. Set ActionInterval in the .config file. This determines the interval in seconds between your service payload code execution
  5. Add your code and functions to <YourServiceName>.vb. The payload execution starts in the function RunPayload()
  6. Run Compile.vbs to build <YourServiceName>.exe
  7. Run ServiceInstall.vbs to install the service
  8. Look in the Windows application event log for messages from the service
TestService.vb
Imports System
Imports System.Threading
Imports System.ServiceProcess
Imports System.Diagnostics
Imports System.Configuration
Imports System.Reflection

' Todo before using service:
' 1. Rename TestService.vb and TestService.exe.config to <YourServiceName>.vb and <YourServiceName>.exe.config (no spaces in the name, please)
' 2. Do a search/replace on all instances of the string "TestService" in this source file to name your service. Use the same <YourServiceName> as in step 1
' 3. Set the service process account (Me.ServiceProcessInstaller1.Account) to either "ServiceAccount.NetworkService", "ServiceAccount.LocalService", "ServiceAccount.LocalSystem" or "ServiceAccount.User" according to your security design. Note that the NetworkService and LocalService accounts may need explicit read/execute NTFS permissions on the folder containing the service files for the service to be allowed to start
' 4. Set ActionInterval in the .config file. This determines the interval in seconds between your service payload code execution
' 5. Add your code and functions to <YourServiceName>.vb. The payload execution starts in the function RunPayload()
' 6. Run Compile.vbs to build <YourServiceName>.exe
' 7. Run ServiceInstall.vbs to install the service. There is also a corresponding ServiceUnInstall.vbs that can be used to uninstall the service
' 8. Look in the Windows application event log for messages from the service

<Assembly: AssemblyTitle("TestService")>
<Assembly: AssemblyDescription(".NET Windows Test Service")>
<Assembly: AssemblyCompany("MyCompanyName")>
<Assembly: AssemblyProduct("TestService")>
<Assembly: AssemblyCopyright("Copyright (C) MyCompanyName")>
<Assembly: AssemblyVersion("1.0.0.0")>
<Assembly: CLSCompliant(True)>

Public Class TestService

  Private Shared ServiceThread As Thread
  Private Shared PollingInterval As Integer = 10000
  Private Shared ActionInterval As Integer = ConfigurationManager.AppSettings("ActionInterval")
  Private Shared KeepRunning As Boolean = True

  Public Sub RunPayload()
    ' Put your service payload code and/or function calls here. For example:
    Try
      WriteToEventLog("TestService payload execution", 1000)
    Catch e As Exception
      WriteToEventLog("An error occurred: " & e.Message, 2000, EventLogEntryType.Error)
    End Try
  End Sub

  Public Sub StartWorkerThread()
    Dim WorkerThread As Thread = New Thread(AddressOf RunPayload)
    WorkerThread.Name = "TestService payload thread"
    WorkerThread.Start()
  End Sub

  Public Sub RunScheduler()
    Dim LastActionTime As Date = DateAdd(DateInterval.Day, -1, Date.Now)
    Do While KeepRunning
      If DateDiff(DateInterval.Second, LastActionTime, Date.Now) >= ActionInterval Then
        LastActionTime = Date.Now
        StartWorkerThread()
      End If
      Thread.Sleep(PollingInterval)
    Loop
  End Sub

  Public Function WriteToEventLog( _
      ByVal Entry As String, _
      Optional ByVal EventID As Integer = 0, _
      Optional ByVal EventType As EventLogEntryType = EventLogEntryType.Information, _
      Optional ByVal AppName As String = "TestService", _
      Optional ByVal LogName As String = "Application") As Boolean
    Dim objEventLog As New EventLog()
    Try
      If Not Diagnostics.EventLog.SourceExists(AppName) Then
        Diagnostics.EventLog.CreateEventSource(AppName, LogName)
      End If
      objEventLog.Source = AppName
      objEventLog.WriteEntry(Entry, EventType, EventID)
      Return True
    Catch Ex As Exception
      Return False
    End Try
    objEventLog.Dispose()
  End Function

  Protected Overrides Sub OnStart(ByVal args() As String)
    WriteToEventLog("TestService starting", 1000)
    ServiceThread = New Thread(AddressOf RunScheduler)
    ServiceThread.Name = "TestService scheduler thread"
    ServiceThread.Start()
  End Sub

  Protected Overrides Sub OnStop()
    KeepRunning = False
    WriteToEventLog("TestService stopping. " & _
      "Please note: the worker process will live on for up to " & _
      PollingInterval / 1000 & " seconds before it terminates.", 1000)
  End Sub

End Class

<System.ComponentModel.RunInstaller(True)> _
Public Class ProjectInstaller
  Inherits System.Configuration.Install.Installer

  Public Sub New()
    MyBase.New()
    InitializeComponent()
  End Sub

  Private components As System.ComponentModel.IContainer

  Private Sub InitializeComponent()
    Me.ServiceProcessInstaller1 = New ServiceProcessInstaller
    Me.ServiceInstaller1 = New ServiceInstaller
    Me.ServiceProcessInstaller1.Account = ServiceAccount.LocalSystem
    Me.ServiceProcessInstaller1.Password = Nothing
    Me.ServiceProcessInstaller1.Username = Nothing
    Me.ServiceInstaller1.ServiceName = "TestService"
    Me.ServiceInstaller1.StartType = ServiceStartMode.Automatic
    Me.Installers.AddRange(New System.Configuration.Install.Installer() {Me.ServiceProcessInstaller1, Me.ServiceInstaller1})
  End Sub
  Friend WithEvents ServiceProcessInstaller1 As ServiceProcessInstaller
  Friend WithEvents ServiceInstaller1 As ServiceInstaller

End Class

<Global.Microsoft.VisualBasic.CompilerServices.DesignerGenerated()> _
Partial Class TestService
  Inherits System.ServiceProcess.ServiceBase

  <System.Diagnostics.DebuggerNonUserCode()> _
  Protected Overrides Sub Dispose(ByVal disposing As Boolean)
    Try
      If disposing AndAlso components IsNot Nothing Then
        components.Dispose()
      End If
    Finally
      MyBase.Dispose(disposing)
    End Try
  End Sub

  <MTAThread()> _
  <System.Diagnostics.DebuggerNonUserCode()> _
  Shared Sub Main()
    Dim ServicesToRun() As System.ServiceProcess.ServiceBase
    ServicesToRun = New System.ServiceProcess.ServiceBase() {New TestService}
    System.ServiceProcess.ServiceBase.Run(ServicesToRun)
  End Sub

  Private components As System.ComponentModel.IContainer

  <System.Diagnostics.DebuggerStepThrough()> _
  Private Sub InitializeComponent()
    components = New System.ComponentModel.Container()
    Me.ServiceName = "TestService"
  End Sub

End Class

TestService.exe.config
<?xml version="1.0" encoding="utf-8" ?>
<configuration>
  <appSettings>
    <!-- ActionInterval is the interval in seconds between execution of the service payload. Minimum is 10 seconds and please use multiples of 10  -->
    <add key="ActionInterval" value="600" />
  </appSettings>
</configuration>

ServiceInstall.vbs
Option Explicit

Dim strCurPath
strCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")

If GetOsMajorVersion() >= 6 Then ' UAC elevation needed in Windows Vista, 2008 and 7
  If WScript.Arguments.Length = 0 Then
    Dim objShell
    Set objShell = CreateObject("Shell.Application")
    objShell.ShellExecute "wscript.exe", Chr(34) & WScript.ScriptFullName & Chr(34) & " """ & strCurPath & """", "", "runas", 1
  Else
    CheckServiceExe(WScript.Arguments.Item(0))
    InstallService(WScript.Arguments.Item(0))
  End If
Else
  CheckServiceExe(strCurPath)
  InstallService(strCurPath)
End If

Function InstallService(strCurPath)
  Dim strPathToInstallUtil
  Dim strInstallOptions
  Dim strCommandOutput
  strCommandOutput = ""
  strPathToInstallUtil = GetNewestInstalledFrameworkPath() & "\installutil.exe"
  strInstallOptions = ""
  Dim objFs
  Dim objFolder
  Dim objFile
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFs.GetFolder(strCurPath)
  For Each objFile in objFolder.Files
    If Right(objFile.Name, 4) = ".exe" Then
      strCommandOutput = "Service installation summary:" & vbcrlf & vbcrlf
      strCommandOutput = strCommandOutput & runCMD(strPathToInstallUtil & " " & strInstallOptions & """" & strCurPath & "\" & objFile.Name & """")
      strCommandOutput = strCommandOutput & runCMD("NET START " & Replace(objFile.Name, ".exe", ""))
      If strCommandOutput <> "" Then
        Wscript.Echo(strCommandOutput)
      End If
    End If
  Next
End Function

Function CheckServiceExe(strCurPath)
  Dim blnExeFound
  blnExeFound = False
  Dim objFs
  Dim objFolder
  Dim objFile
  Dim objShell
  Set objShell = Wscript.CreateObject("WScript.Shell")
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFs.GetFolder(strCurPath)
  For Each objFile in objFolder.Files
    If Right(objFile.Name, 4) = ".exe" Then
      blnExeFound = True
      Exit For
    End If
  Next
  If blnExeFound = False Then ' No exe file found in service folder. Run compile script to generate it
    objShell.currentdirectory = strCurPath
    objShell.Run "Compile.vbs", 1, true
  End If
  Set objShell = Nothing
  Set objFs = Nothing
  Set objFolder = Nothing
End Function

Function GetNewestInstalledFrameworkPath()
  Dim objWsh
  Set objWsh = CreateObject("Wscript.Shell")
  Dim strFoundPath
  Dim objFs
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Dim i
  Dim strArrayPaths
  Dim strArrayRegKeys
  strFoundPath = ""
  strArrayPaths = _
    Array("C:\Windows\Microsoft.NET\Framework64\v4.0.30319", _
          "C:\Windows\Microsoft.NET\Framework64\v2.0.50727", _
          "C:\Windows\Microsoft.NET\Framework\v4.0.30319", _
          "C:\Windows\Microsoft.NET\Framework\v2.0.50727")
  strArrayRegKeys = _
    Array("HKLM\Software\Microsoft\NET Framework Setup\NDP\v4\Full\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v2.0.50727\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v4\Full\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v2.0.50727\Install")
  For i = 0 To Ubound(strArrayPaths)
    If objFs.FileExists(strArrayPaths(i) & "\installutil.exe") Then
      On Error Resume Next
      If objWsh.RegRead(strArrayRegKeys(i)) = 1 Then
        If Err.number = 0 Then
          strFoundPath = strArrayPaths(i)
          Exit For
        End If
      End If
      On Error Goto 0
    End If
  Next
  Set objFs = Nothing
  Set objWsh = Nothing
  GetNewestInstalledFrameworkPath = strFoundPath
End Function

Function GetOsMajorVersion()
  Dim objWSHShell
  Set objWSHShell = WScript.CreateObject("WScript.Shell")
  On Error Resume Next
  GetOsMajorVersion = CInt(Left(objWSHShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion"), 1))
  If err.number <> 0 Then
    GetOsMajorVersion = 1000
  End If
  On Error Goto 0
End Function

Function runCMD(strRunCmd)
  Dim objShell, objExec, strOut
  Set objShell = WScript.CreateObject("WScript.Shell")
  Set objExec = objShell.Exec(strRunCmd)
  strOut = ""
  Do While Not objExec.StdOut.AtEndOfStream
    strOut = strOut & objExec.StdOut.ReadLine() & vbcrlf
  Loop
  Set objShell = Nothing
  Set objExec = Nothing
  runCMD = strOut
End Function

ServiceUninstall.vbs
Option Explicit

Dim strCurPath
strCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")

If GetOsMajorVersion() >= 6 Then ' UAC elevation needed in Windows Vista, 2008 and 7
  If WScript.Arguments.Length = 0 Then
    Dim objShell
    Set objShell = CreateObject("Shell.Application")
    objShell.ShellExecute "wscript.exe", Chr(34) & WScript.ScriptFullName & Chr(34) & " """ & strCurPath & """", "", "runas", 1
  Else
    UnInstallService(WScript.Arguments.Item(0))
  End If
Else
  UnInstallService(strCurPath)
End If

Function UnInstallService(strCurPath)
  Dim strPathToInstallUtil
  Dim strInstallOptions
  Dim strCommandOutput
  strCommandOutput = ""
  strPathToInstallUtil = GetNewestInstalledFrameworkPath() & "\installutil.exe"
  strInstallOptions = "/u "
  Dim objFs
  Dim objFolder
  Dim objFile
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFs.GetFolder(strCurPath)
  For Each objFile in objFolder.Files
    If Right(objFile.Name, 4) = ".exe" Then
      strCommandOutput = "Service uninstallation summary:" & vbcrlf & vbcrlf
      strCommandOutput = strCommandOutput & runCMD("NET STOP " & Replace(objFile.Name, ".exe", ""))
      strCommandOutput = strCommandOutput & runCMD(strPathToInstallUtil & " " & strInstallOptions & """" & strCurPath & "\" & objFile.Name & """")
      If strCommandOutput <> "" Then
        Wscript.Echo(strCommandOutput)
      End If
    End If
  Next
End Function

Function GetNewestInstalledFrameworkPath()
  Dim objWsh
  Set objWsh = CreateObject("Wscript.Shell")
  Dim strFoundPath
  Dim objFs
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Dim i
  Dim strArrayPaths
  Dim strArrayRegKeys
  strFoundPath = ""
  strArrayPaths = _
    Array("C:\Windows\Microsoft.NET\Framework64\v4.0.30319", _
          "C:\Windows\Microsoft.NET\Framework64\v2.0.50727", _
          "C:\Windows\Microsoft.NET\Framework\v4.0.30319", _
          "C:\Windows\Microsoft.NET\Framework\v2.0.50727")
  strArrayRegKeys = _
    Array("HKLM\Software\Microsoft\NET Framework Setup\NDP\v4\Full\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v2.0.50727\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v4\Full\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v2.0.50727\Install")
  For i = 0 To Ubound(strArrayPaths)
    If objFs.FileExists(strArrayPaths(i) & "\installutil.exe") Then
      On Error Resume Next
      If objWsh.RegRead(strArrayRegKeys(i)) = 1 Then
        If Err.number = 0 Then
          strFoundPath = strArrayPaths(i)
          Exit For
        End If
      End If
      On Error Goto 0
    End If
  Next
  Set objFs = Nothing
  Set objWsh = Nothing
  GetNewestInstalledFrameworkPath = strFoundPath
End Function

Function GetOsMajorVersion()
  Dim objWSHShell
  Set objWSHShell = WScript.CreateObject("WScript.Shell")
  On Error Resume Next
  GetOsMajorVersion = CInt(Left(objWSHShell.RegRead("HKLM\Software\Microsoft\Windows NT\CurrentVersion\CurrentVersion"), 1))
  If err.number <> 0 Then
    GetOsMajorVersion = 1000
  End If
  On Error Goto 0
End Function

Function runCMD(strRunCmd)
  Dim objShell, objExec, strOut
  Set objShell = WScript.CreateObject("WScript.Shell")
  Set objExec = objShell.Exec(strRunCmd)
  strOut = ""
  Do While Not objExec.StdOut.AtEndOfStream
    strOut = strOut & objExec.StdOut.ReadLine() & vbcrlf
  Loop
  Set objShell = Nothing
  Set objExec = Nothing
  runCMD = strOut
End Function

Compile.vbs
Option Explicit

Dim strPathToCompiler
Dim strCompileOptions
Dim strSourceCodeExt
Dim strCurPath
Dim strCommandOutput
strCommandOutput = ""
strCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
strPathToCompiler = GetNewestInstalledFrameworkPath() & "\vbc.exe"
strCompileOptions = "/target:winexe /nologo"
strSourceCodeExt = ".vb"
Dim objFs
Dim objFolder
Dim objFile
Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder(strCurPath)
For Each objFile in objFolder.Files
  If Right(objFile.Name, 3) = strSourceCodeExt Then
    strCommandOutput = runCMD(strPathToCompiler & " /out:""" & strCurPath & "\" & Left(objFile.Name, InStr(objFile.Name, strSourceCodeExt)) & "exe"" " & strCompileOptions & " """ & objFile.Name & """")
    If strCommandOutput <> "" Then
      Wscript.Echo(strCommandOutput)
    End If
  End If
Next

Function GetNewestInstalledFrameworkPath()
  Dim objWsh
  Set objWsh = CreateObject("Wscript.Shell")
  Dim strFoundPath
  Dim objFs
  Set objFs = CreateObject("Scripting.FileSystemObject")
  Dim i
  Dim strArrayPaths
  Dim strArrayRegKeys
  strFoundPath = ""
  strArrayPaths = _
    Array("C:\Windows\Microsoft.NET\Framework64\v4.0.30319", _
          "C:\Windows\Microsoft.NET\Framework64\v2.0.50727", _
          "C:\Windows\Microsoft.NET\Framework\v4.0.30319", _
          "C:\Windows\Microsoft.NET\Framework\v2.0.50727")
  strArrayRegKeys = _
    Array("HKLM\Software\Microsoft\NET Framework Setup\NDP\v4\Full\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v2.0.50727\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v4\Full\Install", _
          "HKLM\Software\Microsoft\NET Framework Setup\NDP\v2.0.50727\Install")
  For i = 0 To Ubound(strArrayPaths)
    If objFs.FileExists(strArrayPaths(i) & "\vbc.exe") Then
      On Error Resume Next
      If objWsh.RegRead(strArrayRegKeys(i)) = 1 Then
        If Err.number = 0 Then
          strFoundPath = strArrayPaths(i)
          Exit For
        End If
      End If
      On Error Goto 0
    End If
  Next
  Set objFs = Nothing
  Set objWsh = Nothing
  GetNewestInstalledFrameworkPath = strFoundPath
End Function

Function runCMD(strRunCmd)
  Dim objShell, objExec, strOut
  Set objShell = WScript.CreateObject("WScript.Shell")
  Set objExec = objShell.Exec(strRunCmd)
  strOut = ""
  Do While Not objExec.StdOut.AtEndOfStream
    strOut = strOut & objExec.StdOut.ReadLine() & vbcrlf
  Loop
  Set objShell = Nothing
  Set objExec = Nothing
  runCMD = strOut
End Function
Tags: dotnet
Page last updated 2016-02-07 20:19. Some rights reserved (CC by 3.0)