?
Solved

Creating a Service

Posted on 2001-09-09
5
Medium Priority
?
265 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
5 Comments
 
LVL 4

Expert Comment

by:wileecoy
ID: 6469420
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
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.
0
 
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
0
 
LVL 1

Accepted Solution

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

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
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…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
Suggested Courses

771 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