[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now


Creating a Service

Posted on 2001-09-09
Medium Priority
Last Modified: 2007-11-27
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.
Question by:innovate

Expert Comment

ID: 6469420
Here is a link to a recent question that is similar.




Author Comment

ID: 6469502
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.
LVL 70

Expert Comment

by:Éric Moreau
ID: 6472269
If you are serious in developing a service with VB, see this: http://www.desaware.com/NTToolkitL2.htm

Accepted Solution

kepeter earned 200 total points
ID: 6473345
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).


Author Comment

ID: 6492538
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.

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Suggested Courses

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question