Windows Service code example in VB.Net

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

<?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>

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

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

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