Solved

Creating a Service

Posted on 2001-09-09
5
252 Views
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.
0
Comment
Question by:innovate
5 Comments
 
LVL 4

Expert Comment

by:wileecoy
Comment Utility
Here is a link to a recent question that is similar.

http://www.experts-exchange.com/jsp/qShow.jsp?ta=visualbasic&qid=20179378

hth.

Wileecoy.
0
 
LVL 2

Author Comment

by:innovate
Comment Utility
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.
0
 
LVL 69

Expert Comment

by:Éric Moreau
Comment Utility
If you are serious in developing a service with VB, see this: http://www.desaware.com/NTToolkitL2.htm
0
 
LVL 1

Accepted Solution

by:
kepeter earned 50 total points
Comment Utility
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
      Else
        '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..."
      Else
        '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
      NTService.StartService
  End Select
 
Exit_Form_Load:
  Exit Sub

Error_Form_Load:
  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_NTService_Start:
  Exit Sub
 
Error_NTService_Start:
  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_NTService_Stop:
  Exit Sub
 
Error_NTService_Stop:
  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)
   
          .MoveFirst
          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
           
            .MoveNext
          Loop
        End If
      End With
     
      oLogData.Save
    Else
      frmService.NTService.LogEvent svcEventError, svcMessageError, "Can't open entity!" & vbNewLine & Err.Source & vbNewLine & "TimerProc"
    End If
  Else
    frmService.NTService.LogEvent svcEventError, svcMessageError, "Can't update parameters!" & vbNewLine & Err.Source & vbNewLine & "TimerProc"
  End If
 
Exit_TimerProc:
  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
    oLogData.Term
  End If
  Set oLogData = Nothing
  Exit Sub
 
Error_TimerProc:
  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 goMSMQQueue = oQueueInfo.Open(MQ_RECEIVE_ACCESS, MQ_DENY_RECEIVE_SHARE)
 
  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.Open
        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
   
Exit_goMSMQEvent_Arrived:
  Set oMSMQMessage = Nothing
  Set oMSMQQueue = Nothing
  Exit Sub
 
Error_goMSMQEvent_Arrived:
  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_goMSMQEvent_ArrivedError:
  Exit Sub

Error_goMSMQEvent_ArrivedError:
  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).

Peter
0
 
LVL 2

Author Comment

by:innovate
Comment Utility
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.
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
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…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

743 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now