Creating a Service

I'm creating a service using VB6 (NTSVC.OCX)and was hoping to find some GOOD examples.  I've got the MS one but it's a bit limited.  To give you some idea of what I need.

I'm creating a service that runs in two modes, it can be started, carries out it's stuff and then exits or runs while monitoring some registry values and reacts to changes and additions.
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Here is a link to a recent question that is similar.


innovateAuthor Commented:
Sorry the line in my question "I've got the MS one" actually refers to the MicroSoft example.  I already have it. I am looking for BETTER and more complete information.
Éric MoreauSenior .Net ConsultantCommented:
If you are serious in developing a service with VB, see this:
I don't realy understood what does it mean better example.
After you use NTSVC.OCX the execution/installation of the service is easy, and everything after it is up to you.

Anyway I put here a service I run which:
1. Listening for a specified queue on the MSMQ server.
2. Every 5 minutes check out a log file and do what it need.

-- This is the code of the form where the control (NTSVC.OCX) sits
Option Explicit

' All message boxes, but help message, removed on 05/08/2001 - Peter

Private goListener As clsListener

Private Sub Form_Load()
On Error GoTo Error_Form_Load
  NTService.Dependencies = "MSMQ" & vbNullChar
  Select Case (Trim(Command()))
    Case "/i", "/I"
      If (NTService.Install() = True) Then
        'MsgBox NTService.DisplayName & " successfully installed..."
        Shell "net start RMSMQ", vbHide
        'MsgBox NTService.DisplayName & " failed to install!"
      End If
      Unload Me
    Case "/u", "/U"
      Shell "net stop RMSMQ", vbHide
      If (NTService.Uninstall() = True) Then
        'MsgBox NTService.DisplayName & " successfully uninstalled..."
        'MsgBox NTService.DisplayName & " failed to uninstall!"
      End If
      Unload Me
    Case "/h", "/H", "/?"
      MsgBox "Rashim MSMQ Server v1.0 Copyright 2000, Rashim LTD." & vbNewLine & _
             vbNewLine & _
             "Usage:" & vbNewLine & _
             "MSMQServer {/i|/I|/u|/U|/h|/H|/?}" & vbNewLine & _
             vbTab & "/i|/I to install and start service." & vbNewLine & _
             vbTab & "/u|/U to stop and uninstall service." & vbNewLine & _
             vbTab & "/h|/H|/? to display this help screen." & vbNewLine
      Unload Me
    Case Else
  End Select
  Exit Sub

  NTService.LogEvent svcEventError, svcMessageError, Err.Description & "(" & Err.Number & ")" & vbNewLine & Err.Source & vbNewLine & "Load"
  Resume Exit_Form_Load
End Sub

Private Sub NTService_Start(Success As Boolean)
On Error GoTo Error_NTService_Start

  ' Load MSMQ Listener
  Set goListener = New prjMSMQServer.clsListener
  ' Strat timer for scheduling
  TimerID = SetTimer(0, 0, 300000, AddressOf TimerProc)
  Success = True
  Exit Sub
  NTService.LogEvent svcEventError, svcMessageError, Err.Description & "(" & Err.Number & ")" & vbNewLine & Err.Source & vbNewLine & "Start Service"
  Success = False
  Resume Exit_NTService_Start
End Sub

Private Sub NTService_Stop()
On Error GoTo Error_NTService_Stop
  ' Kill scheduler's timer
  KillTimer 0, TimerID

  ' Remove MSMQ listener
  Set goListener = Nothing
  Exit Sub
  NTService.LogEvent svcEventError, svcMessageError, Err.Description & "(" & Err.Number & ")" & vbNewLine & Err.Source & vbNewLine & "Stop Service"
  Resume Exit_NTService_Stop
End Sub
-- End of form code

-- This code must be in a basic module because it contains a call-back function
Option Explicit

Public TimerID As Long

Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

' Read records from log and execute waiting process
Public Sub TimerProc(ByVal hwnd As Long, _
                     ByVal uMsg As Long, _
                     ByVal idEvent As Long, _
                     ByVal dwTime As Long)
On Error GoTo Error_TimerProc

  Dim oLogData        As prjDataServices.clsEntity
  Dim sWC             As String
  Dim sTemp           As String
  Dim oParams         As RashimUtils.rParameters
  Dim oNewOptions     As RashimUtils.clsEntityOptions
  Dim oNewParams      As RashimUtils.rParameters
  Dim oNewSelRs       As ADODB.Recordset
  Dim sXML            As String
  Dim oRUtils         As RashimUtils.RUtils
  Dim oMSMQQueueInfo  As MSMQ.MSMQQueueInfo
  Dim oMSMQMsg        As MSMQ.MSMQMessage
  Dim oMSMQQueue      As MSMQ.MSMQQueue
  Dim lIndex          As Long
  Dim lPos            As Long
  Set oLogData = New prjDataServices.clsEntity
  oLogData.EntityID = "ENTITY_AS_rRsBatch_Log"
  Set oParams = New RashimUtils.rParameters
  sWC = "RecordType = 0 and LogDate = '" & Format(Date, "dd/mm/yyyy") & "' and LogTime <= '" & Format(Time, "hh:nn") & "'"
  If (oParams.Update("ENTITY_AS_rRsBatch_Log", "rRsBatch_Log", "Batch_Log", "ProcessID", "W", cpFieldString, , , , sWC) = True) Then
    If (oLogData.OpenEntity(oParams.hRecordset) = True) Then
      ' True
      With oLogData.hRsItem("rRsBatch_Log")
        If (.RecordCount > 0) Then
          Set oRUtils = New RashimUtils.RUtils
          Set oMSMQQueueInfo = New MSMQ.MSMQQueueInfo
          oMSMQQueueInfo.PathName = oRUtils.REQUESTS_QUEUE
          Set oMSMQQueue = oMSMQQueueInfo.Open(MQ_SEND_ACCESS, MQ_DENY_NONE)
          Do While (.EOF = False)
            lPos = 1
            sTemp = .Fields("Batch_Log_LogData").Value
            For lIndex = 0 To 3
              lPos = InStr(lPos, sTemp, ".", vbTextCompare) + 1
            Next lIndex
            Set oMSMQMsg = New MSMQ.MSMQMessage
            oMSMQMsg.AppSpecific = .Fields("Batch_Log_LogUsr").Value
            oMSMQMsg.Label = "EXECUTE(" & Left(.Fields("Batch_Log_LogData").Value, lPos - 2) & ")"
            sXML = Mid(.Fields("Batch_Log_LogData").Value, lPos)
            oRUtils.LogData2Rs sXML, oNewOptions, oNewParams, oNewSelRs
            oNewOptions.Update "SCHEDULE_DO", False
            oRUtils.LogData2Rs sXML, oNewOptions, oNewParams, oNewSelRs, True
            oMSMQMsg.Body = sXML
            oMSMQMsg.Send oMSMQQueue
            .Delete adAffectCurrent
        End If
      End With
      frmService.NTService.LogEvent svcEventError, svcMessageError, "Can't open entity!" & vbNewLine & Err.Source & vbNewLine & "TimerProc"
    End If
    frmService.NTService.LogEvent svcEventError, svcMessageError, "Can't update parameters!" & vbNewLine & Err.Source & vbNewLine & "TimerProc"
  End If
  Set oRUtils = Nothing
  Set oMSMQQueueInfo = Nothing
  Set oMSMQMsg = Nothing
  Set oMSMQQueue = Nothing
  Set oNewOptions = Nothing
  Set oNewParams = Nothing
  Set oNewSelRs = Nothing
  Set oParams = Nothing
  If Not (oLogData Is Nothing) Then
  End If
  Set oLogData = Nothing
  Exit Sub
  frmService.NTService.LogEvent svcEventError, svcMessageError, Err.Description & "(" & Err.Number & ")" & vbNewLine & Err.Source & vbNewLine & "TimerProc"
  Resume Exit_TimerProc
End Sub
-- End of basic module code

-- This is the code of the calss named clsListener
Option Explicit

Private goMSMQQueue As MSMQ.MSMQQueue
Private WithEvents goMSMQEvent As MSMQ.MSMQEvent

' Connecting to the MSMQ
Private Sub Class_Initialize()
  Dim oQueueInfo As MSMQ.MSMQQueueInfo
  Dim oUtils As RashimUtils.RUtils
  Set oUtils = New RashimUtils.RUtils
  Set oQueueInfo = New MSMQ.MSMQQueueInfo
  oQueueInfo.PathName = oUtils.REQUESTS_QUEUE
  Set goMSMQEvent = New MSMQ.MSMQEvent
  goMSMQQueue.EnableNotification goMSMQEvent, MQMSG_FIRST, 1000
  Set oUtils = Nothing
  Set oQueueInfo = Nothing
End Sub

Private Sub Class_Terminate()
  Set goMSMQEvent = Nothing
  Set goMSMQQueue = Nothing
End Sub

' Passes the message to the MSMQRunner executable
' -c:   - The command like 'CANCEL'
' -u:   - User no
' -id:  - MSMQ message id
' -p:   - Path to file containing the parameters
' -o:   - Object name used to run the job
Private Sub goMSMQEvent_Arrived(ByVal Queue As Object, ByVal Cursor As Long)
On Error GoTo Error_goMSMQEvent_Arrived
  Dim oMSMQQueue As MSMQ.MSMQQueue
  Dim oMSMQMessage As MSMQ.MSMQMessage
  Dim sParamC As String
  Dim sParamU As String
  Dim sParamID As String
  Dim sParamO As String
  Dim sParamP As String
  Dim oXml As ADODB.Stream
  Dim lPos As Long
  Dim sCmd As String
  Dim sMsg As String
  Set oMSMQQueue = Queue
  Set oMSMQMessage = oMSMQQueue.ReceiveCurrent(ReceiveTimeout:=0)
  If Not (oMSMQMessage Is Nothing) Then
    lPos = InStr(1, oMSMQMessage.Label, "(", vbTextCompare)
    sCmd = Left(oMSMQMessage.Label, lPos - 1)
    sMsg = Mid(oMSMQMessage.Label, lPos + 1, Len(oMSMQMessage.Label) - lPos - 1)
    sParamC = "-c:" & sCmd
    sParamU = "-u:" & oMSMQMessage.AppSpecific
    sParamO = "-o:" & sMsg
    Select Case UCase(sCmd)
      Case "CANCEL"
        sParamID = "-id:" & Join(oMSMQMessage.Body)
        sParamP = "-p:"
      Case "EXECUTE", "SCHEDULE"
        sParamID = "-id:" & Join(oMSMQMessage.Id)
        sParamP = "-p:" & App.Path & "\" & Join(oMSMQMessage.Id)
        Set oXml = New ADODB.Stream
        oXml.WriteText oMSMQMessage.Body
        oXml.SaveToFile App.Path & "\" & Join(oMSMQMessage.Id), adSaveCreateOverWrite
    End Select
    frmService.NTService.LogEvent svcEventInformation, svcMessageInfo, "MSMQRunner " & sParamC & sParamU & sParamID & sParamO & sParamP
    Shell "MSMQRunner.exe " & sParamC & sParamU & sParamID & sParamO & sParamP, vbHide
  End If
  goMSMQQueue.EnableNotification goMSMQEvent, MQMSG_FIRST, 1000
  Set oMSMQMessage = Nothing
  Set oMSMQQueue = Nothing
  Exit Sub
  frmService.NTService.LogEvent svcEventError, svcMessageError, Err.Description & "(" & Err.Number & ")" & vbNewLine & Err.Source & vbNewLine & "Message Arrived"
  Resume Exit_goMSMQEvent_Arrived
End Sub

' Error
Private Sub goMSMQEvent_ArrivedError(ByVal Queue As Object, ByVal ErrorCode As Long, ByVal Cursor As Long)
On Error GoTo Error_goMSMQEvent_ArrivedError

  If (ErrorCode <> MQ_ERROR_IO_TIMEOUT) Then
    frmService.NTService.LogEvent svcEventError, svcMessageError, "Error when try to notify messages in queue '" & UCase(Queue.QueueInfo.PathName) & "'. Error code " & ErrorCode
  End If
  goMSMQQueue.EnableNotification goMSMQEvent, MQMSG_FIRST, 1000

  Exit Sub

  frmService.NTService.LogEvent svcEventError, svcMessageError, Err.Description & "(" & Err.Number & ")" & vbNewLine & Err.Source & vbNewLine & "Message Arrived Error"
  Resume Exit_goMSMQEvent_ArrivedError
End Sub

' Default 'Join' function can't work on byte array
Private Function Join(IDArray() As Byte)
  Dim sRet As String
  Dim lIndex As Long
  Dim lCount As Long
  lCount = UBound(IDArray())
  For lIndex = 0 To lCount
    sRet = sRet & IDArray(lIndex) & "."
  Next lIndex
  sRet = Left(sRet, Len(sRet) - 1)
  Join = sRet
End Function
-- End of class module code

When you write services, take care of these things:
1. The service for most run under the SYSTEM account, which has a reduced environment (e.g. no printers). If you need some interactive actions declare the owner account properly.
2. If your service depend on other existing services, you need to change some code in the original Microsoft (VC++) code (it can't handle dependencies as it cames).


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
innovateAuthor Commented:
Thanks all, the points have to go to kepeter for his huge piece of code.  I actually got the service going but get a "Service stopped error" even though I'm stopping it internally.

The problem I've got now is how to start it from an MTS activeX DLL!!

See the next question.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.