Visual Basic as a Service 2

[ASPVBNerd]

Is it possible to create an application that can run as a service programmed with Visual Basic 6?
I have read the msdn help and that article was about version 4 and 5 and microsft doesn't recommend this.
But I have copied the code from the help and install my application with this command from dos MyService.exe install
It now appears in the services dialog but the exe file isn't available in the service properties.

Is it possible to create a application coded by vb6 to run as a service?

 

[zarkon4]

Yes, I have done it. go to

http://www.smsoft.ru/en/ntservice.htm

at the bottom left is a download. I used this and it works
great!

 

[chiph]

Microsoft still doesn't recommend this, but it's possible. There's an NTSVC.OCX available via google search. The things to watch out for are:
1) Do not set any breakpoints in the OnStart or OnStop events
2) To debug it, the easiest way is to send debug msgs to the NT Event log.

Chip H.


____________________________________________________________________
Donate to Katrina relief:

http://s1.amazon.com/paypage/PELYGQVJ8Q7IB/103-6821258-5919825

If you want to get the best response to a question, please read FAQ222-2244 first

 

[ASPVBNerd]

I am little confused right now.
I have a few questions about NTSVC.OCX that i was hoping that someone could answer.

1. Is NTSVC.OCX suppose to call a form and from there the form. I dont want to show my form. Not even in taskbar at the program bar. It should only be displayed in the process bar.

2. Why is my service started and stopped when it has called the form.

 

[zarkon4]

Do not use a form, get the sample code I mentioned above
It does not use NTSVC.ocx.

 

[chiph]

A service should not have a form. You should only be using classes and modules.

This is because a service should not interact with the desktop because it starts when the machine boots, not when someone logs in (which is when the desktop gets created).

Chip H.


____________________________________________________________________
Donate to Katrina relief:

http://s1.amazon.com/paypage/PELYGQVJ8Q7IB/103-6821258-5919825

If you want to get the best response to a question, please read FAQ222-2244 first

 

[Sheco]

About a year ago I had good luck with a service derived from the code in the link that zarkon4 provided... the service is still running.

 

[ASPVBNerd]

I will go home and read zarkon4 example and se if i understand something.

Last question, i promise.

A service should not have a form. You should only be using classes and modules.

Okay, I should create an a project using Standard exe and then remove the form and then add classes and modules. is that correct chiph?
And in my class i would declare for example like this.

Public tektip As NTService.NTService
tektip.StartService

chiph, please help me getting started. I feel like a stupied a**.

George

 

[zarkon4]

The service I use is a standard executable. It has no forms,
just modules. In one of the modules I have a Sub called Main
It is set as my startup in the project properties. I use mine as a service that runs reports at night. the reports email themselves to desired recipients. The following is a snippet of the main code.


'The following are used for the service itself

Public Const Service_Name = "LPReportDriver"
Public Const INFINITE = -1& ' Infinite timeout
Private Const WAIT_TIMEOUT = 258&

Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWDEFAULT As Long = 10
Private Const SE_ERR_NOASSOC As Long = 31

Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(1 To 128) As Byte ' Maintenance string for PSS usage
End Type

Public Const VER_PLATFORM_WIN32_NT = 2&

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

Public hStopEvent As Long, hStartEvent As Long, hStopPendingEvent
Public IsNT As Boolean, IsNTService As Boolean
Public ServiceName() As Byte, ServiceNamePtr As Long


'The following are used to start the report
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'The following are used to find and kill the lotus notes process that have been
'started by this service
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'used to search for the process
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias _
"CreateToolhelp32Snapshot" (ByVal lFlags As Long, _
ByVal lProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long


Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long 'The processID
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH 'The exe name of the process
End Type



'SQL Server connection string
Private Const CONNECT_STRING As String = "Provider=SQLOLEDB.1;" & _
"INTEGRATED SECURITY=SSPI;" & _
"PERSIT SECURITY INFO=FALSE;" & _
"INITIAL CATALOG=LEWIS;DATA SOURCE=PUMPS"

Private Sub Main()
Dim hnd As Long
Dim h(0 To 1) As Long
Dim hWndDesk As Long
Dim success As Long
Dim adoConn As ADODB.Connection
Dim adoRptDriver As ADODB.Recordset

' Only one instance
If App.PrevInstance Then Exit Sub
' Check OS type
IsNT = CheckIsNT()
' Creating events
hStopEvent = CreateEvent(0, 1, 0, vbNullString)
hStopPendingEvent = CreateEvent(0, 1, 0, vbNullString)
hStartEvent = CreateEvent(0, 1, 0, vbNullString)
ServiceName = StrConv(Service_Name, vbFromUnicode)
ServiceNamePtr = VarPtr(ServiceName(LBound(ServiceName)))
If IsNT Then
' Trying to start service
hnd = StartAsService
h(0) = hnd
h(1) = hStartEvent
' Waiting for one of two events: sucsessful service start (1) or
' terminaton of service thread (0)
IsNTService = WaitForMultipleObjects(2&, h(0), 0&, INFINITE) = 1&
If Not IsNTService Then
CloseHandle hnd
'MsgBox "This program must be started as service."
MessageBox 0&, "This program must be started as a service.", App.Title, vbInformation Or vbOKOnly Or vbMsgBoxSetForeground
End If
Else
MessageBox 0&, "This program is only for Windows NT/2000/XP.", App.Title, vbInformation Or vbOKOnly Or vbMsgBoxSetForeground
End If

If IsNTService Then
' ******************
' Here you may initialize and start service's objects
' These objects must be event-driven and must return control
' immediately after starting.
' ******************
SetServiceState SERVICE_RUNNING
App.LogEvent "LPReportDriver Service started"

'Start up The lotus notes processes for the reports to send email
hWndDesk = GetDesktopWindow()
success = ShellExecute(hWndDesk, "Open", "NLNOTES.EXE" & Chr(34) & _
"=c:\Program Files\lotus\notes\notes.ini" & _
Chr(34), vbNullString, vbNullString, SW_SHOWNORMAL)


On Error GoTo ErrorHandler

Do
' ******************
' It is main service loop. Here you may place statements
' which perform useful functionality of this service.
' ******************

Set adoConn = New ADODB.Connection
Set adoRptDriver = New ADODB.Recordset
adoConn.ConnectionTimeout = 0
adoConn.CommandTimeout = 0
adoConn.Open CONNECT_STRING

adoRptDriver.Open "SELECT * FROM ReportDriver", adoConn, adOpenKeyset, adLockOptimistic

Do Until adoRptDriver.EOF
'If the report time and date of next run matches the current time
'and date the fire it.
If Format(adoRptDriver!RunTime, "h:mm AM/PM") = _
Format(Now, "h:mm AM/PM") _
And Format(adoRptDriver!NextRun, "mm/dd/yyyy") = _
Format(Now, "mm/dd/yyyy") Then
'calc the next runtime
adoRptDriver!NextRun = CalcNextRun(adoRptDriver!ReportType)

'set last run
adoRptDriver!LastRun = Format(Now, "mm/dd/yyyy")

adoRptDriver.Update

App.LogEvent "LPReportDriver Service running " & adoRptDriver!ReportName

'Get a window handle for the report process
hWndDesk = GetDesktopWindow()

success = ShellExecute(hWndDesk, "Open", adoRptDriver!ReportExe, _
vbNullString, vbNullString, SW_SHOWNORMAL)

App.LogEvent adoRptDriver!ReportName & " next run is " & _
adoRptDriver!NextRun

If success = 0 Then
App.LogEvent "Failed to start " & adoRptDriver!ReportName
Else
App.LogEvent adoRptDriver!ReportName & "Started"
End If

End If

adoRptDriver.MoveNext

Loop

adoRptDriver.Close
adoConn.Close
Set adoRptDriver = Nothing
Set adoConn = Nothing

' Loop repeats every second. You may change this interval.
'1000 - second, 60000 - minute, 300000 - 5 mins
Loop While WaitForSingleObject(hStopPendingEvent, 60000) = WAIT_TIMEOUT

ErrorHandler:
If Err.Number <> 0 Then
App.LogEvent "LPReportDriver ERROR - " & Err.Number & " - " & _
Err.Description
On Error Resume Next
adoRptDriver.Close
adoConn.Close
Set adoRptDriver = Nothing
Set adoConn = Nothing
End If
' ******************
' Here you may stop and destroy service's objects
' ******************
'First stop the Lotus Notes Processes
'nlnotes.exe processtree, nnotesmm.exe
If FindAndKillLotus = True Then
App.LogEvent "LPReportDriver stopped Lotus Processes"
Else
App.LogEvent "LPReportDriver Unable to terminate Lotus Processes"
End If
SetServiceState SERVICE_STOPPED
App.LogEvent "LPReportDriver Service stopped"
SetEvent hStopEvent
' Waiting for service thread termination
WaitForSingleObject hnd, INFINITE
CloseHandle hnd
End If
CloseHandle hStopEvent
CloseHandle hStartEvent
CloseHandle hStopPendingEvent
End Sub

' CheckIsNT() returns True, if the program runs
' under Windows NT or Windows 2000, and False
' otherwise.
Public Function CheckIsNT() As Boolean
Dim OSVer As OSVERSIONINFO
OSVer.dwOSVersionInfoSize = LenB(OSVer)
GetVersionEx OSVer
CheckIsNT = OSVer.dwPlatformId = VER_PLATFORM_WIN32_NT
End Function

Private Function FindAndKillLotus() As Boolean

Dim lhSnapShot As Long
Dim pe32 As PROCESSENTRY32
Dim lRet As Long
Dim lProcID As Long
Dim strProcName As String
Dim lhProcess As Long

'Get a picture of All the process
lhSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)

If lhSnapShot = 0 Then
App.LogEvent "LPReportDriver Unable to get a snapshot of processes"
FindAndKillLotus = False
Else
pe32.dwSize = Len(pe32)
lRet = ProcessFirst(lhSnapShot, pe32)
Do While lRet
strProcName = StripProcName(pe32.szExeFile)
'App.LogEvent "'" & CStr(pe32.th32ProcessID) & "'-'" & strProcName & "'"
If InStr(1, strProcName, "nlnotes.exe") > 0 Or InStr(1, strProcName, "ntaskldr.exe") > 0 Or _
InStr(1, strProcName, "nnotesmm.exe") > 0 Then

'kill the process
App.LogEvent "LPReportDriver killing process: " & CStr(pe32.th32ProcessID) & _
"-" & strProcName
lhProcess = OpenProcess(PROCESS_TERMINATE, 0, pe32.th32ProcessID)
TerminateProcess lhProcess, 0
CloseHandle lhProcess

End If
lRet = ProcessNext(lhSnapShot, pe32)
Loop
CloseHandle lhSnapShot
FindAndKillLotus = True
End If

End Function

Private Function StripProcName(strProcName As String) As String

Dim strStrip As String

strStrip = Trim(strProcName)
While (Asc(Right(strStrip, 1)) < 32)
strStrip = Left(strStrip, (Len(strStrip) - 1))
Wend
StripProcName = strStrip

End Function

Public Function CalcNextRun(strType As String) As String

Dim iDayofWeek As Integer
Dim sAdjDate As String

Select Case strType
Case "D"
iDayofWeek = Weekday(DateAdd("d", 1, Now))
sAdjDate = DateAdd("d", 1, Now)
If iDayofWeek = 7 Then
CalcNextRun = DateAdd("d", 2, sAdjDate)
Else
CalcNextRun = sAdjDate
End If
Case "W"
CalcNextRun = DateAdd("d", 7, Now)
Case "M"
If Day(Now) >= 27 Then
'calc next last workday of month
iDayofWeek = Weekday(DateAdd("m", Month(Now) - 1, "01/31/" & Year(Now)))
sAdjDate = DateAdd("m", Month(Now) - 1, "01/31/" & Year(Now))
If iDayofWeek = 1 Then
CalcNextRun = DateAdd("d", -2, sAdjDate)
ElseIf iDayofWeek = 7 Then
CalcNextRun = DateAdd("d", -1, sAdjDate)
Else
CalcNextRun = sAdjDate
End If
Else
'calc next first work day of month
iDayofWeek = Weekday(DateAdd("m", Month(Now), "01/01/" & Year(Now)))
sAdjDate = DateAdd("m", Month(Now), "01/01/" & Year(Now))
If iDayofWeek = 1 Then
CalcNextRun = DateAdd("d", 1, sAdjDate)
ElseIf iDayofWeek = 7 Then
CalcNextRun = DateAdd("d", 2, sAdjDate)
Else
CalcNextRun = sAdjDate
End If
End If
Case "Y"
iDayofWeek = Weekday(DateAdd("yyyy", 1, "01/01/" & Year(Now)))
sAdjDate = DateAdd("yyyy", 1, "01/01/" & Year(Now))
If iDayofWeek = 1 Then
CalcNextRun = DateAdd("d", 1, sAdjDate)
ElseIf iDayofWeek = 7 Then
CalcNextRun = DateAdd("d", 2, sAdjDate)
Else
CalcNextRun = sAdjDate
End If
Case Else
CalcNextRun = Format(Now, "mm/dd/yyyy")
End Select

End Function

 

[chiph]

Yes, instead of your startup object being a form, you'd use a Sub Main located in a Module.

Chip H.


____________________________________________________________________
Donate to Katrina relief:

http://s1.amazon.com/paypage/PELYGQVJ8Q7IB/103-6821258-5919825

If you want to get the best response to a question, please read FAQ222-2244 first

 

[BobRodes]

<A service should not have a form. You should only be using classes and modules.

Which always made me wonder why Microsoft exposed service capability via a gui-based control as in NTSVC.OCX. Since they've done their best to hide it, they must wonder too.

Bob

 

[dilettante]

Ahh, but a VB6 Form isn't necessarily a user interface object at all. It is quite possible to exploit forms as a sort of enhanced Class module or a control container instantiated using Load and never Showing it at all.

An example is the problem of using WithEvents objects: you can't have arrays of them. One answer is to create UserControls instead of some of your Classes and use a hidden Form as a container for control arrays of them.

This technique plus the careful use of the ActiveX EXE project type can produce some powerful results. I use this approach in custom "remote shells" and similar services to obtain both multitasking and process isolation for client sessions at the server.


"A service should not have a form" isn't strictly accurate for this and other reasons. It is a good general rule though regarding VB Forms as they are typically used in simple client programming. Forms loaded "simply" within a VB6 service will be bound to the first interactive Windows Station found and appear on the default Desktop.

I'd be interested to hear what sorts of options people are using between their services' "admin" interfaces and the services themselves. Pipes? Sockets? Mailslots? Exposed COM interfaces?

 

[Sheco]

I'd be interested to hear what sorts of options people are using between their services' "admin" interfaces and the services themselves. Pipes? Sockets? Mailslots? Exposed COM interfaces?

I tried and failed with COM...although I don't remember exactly what the issue was. Since the service was using a database anyway, i set aside a few tables for a crude metabase type approach and called it done. It was for an internal project so it didn't need to be commercial quality.

 

[BobRodes]

<Ahh, but a VB6 Form isn't necessarily a user interface object at all. It is quite possible to exploit forms as a sort of enhanced Class module or a control container instantiated using Load and never Showing it at all.

Well, yes, that's so, but it seems a bit of a workaround kludge to me to have some visual ui as a means of accomplishing some non ui purpose, that's all.

However, that notwithstanding, I like your ideas. I never ran into the problem of arrays of withevents objects, and your solution is creative and no doubt effective.

Bob

 

[dilettante]

Alas, since we never got an improved product (VB7) many of us find hacks and kludges of such types useful in extending the life of an aging compiler. The trick is finding stable hacks.

 

[chiph]

Which always made me wonder why Microsoft exposed service capability via a gui-based control as in NTSVC.OCX. Since they've done their best to hide it, they must wonder too.

NTSVC.OCX was never a released product -- it was something that a developer at Microsoft thought would be handy to have, and uploaded it to their FTP/Web site. It's no longer there, either as a result of their phasing out VB6 stuff, or because the support engineers got tired of answering questions about an unsupported OCX.

I never had a need to write a control UI for my services -- but if I did I would have used sockets.

Chip H.


____________________________________________________________________
Donate to Katrina relief:

http://s1.amazon.com/paypage/PELYGQVJ8Q7IB/103-6821258-5919825

If you want to get the best response to a question, please read FAQ222-2244 first

 

[ASPVBNerd]

When I try to start my service i get a the message

error 1053: The service did not respond to the start or control request in a timely fasion

I have the code at this link.

http://www.wilder-films.co.uk/vb/vbservice.zip

Most of the the code is from vbcity page.

I was hoping that someone could help me with this problem.

 

[mattKnight]

Are you doing a lot of initialisation at service start up? I would guess that you probably are (or that something is taking longer than you expect)

I've had a quick look at the source code at

http://www.smsoft.ru/en/ntservice.htm

It seems to me that it has not implemented any mechanism for startup monitoring...
(Neither does the code (on quick inspection) provided by zarkon4)
What I mean by start up is that the service communicates back to the Service Control manager and in effect says
"I am still starting, I am at checkpoint X and I expect to take Y mS to complete"

This chatter continues until the service says "I am now started OK". If however, the SCM doesn't receive another call saying "I am still starting etc" within the Y mS, it assumes and error has occurred and flags it!

I would add something like this to the module (and this is a very very simple implementation)

' Required API declaration in addition to others
Private Declare Function SetNTServiceStatus Lib "advapi32.dll" Alias "SetServiceStatus" (ByVal hServiceStatus As Long, lpServiceStatus As SERVICE_STATUS) As Long
Public Function SetServiceStatus(lNewState as long, lCheckpoint as long, lWaitHint as Long) As long

Dim hSCManager As Long, hService As Long, Status As SERVICE_STATUS, lRet as long
lRet = 0
hSCManager = OpenSCManager(0&, 0&, _
                       SC_MANAGER_CONNECT)
If hSCManager Then
    hService = OpenService(hSCManager, StrPtr(Service_Name), SERVICE_QUERY_STATUS)
    If hService Then
        With Status
            .dwCheckpoint = lCheckpoint
            .dwWaitHint = lWaitHint
            .dwCurrentState = lNewState
        end with
        lRet = SetNTServiceStatus(hService, Status) 
        CloseServiceHandle hService
    End If
    CloseServiceHandle hSCManager
End If
    SetServiceStatus = lRet
End Function

The above was written off the cuff and untested, but it gives you the idea.

You then need to put the following in you startup code at appropraite points

SetServiceStatus SERVICE_START_PENDING, 1, 1000

I'd also check quite closely that you startup code is not taking moire time than you expect!







Take Care

Matt
If at first you don't succeed, skydiving is not for you.

 

[ASPVBNerd]

Actually I am not doing very little of initialisation at service start up.
This is the only thing that I am doing with the statup.

Public Sub subLogCommand(strCommand As String)
  '***  log all commands to a text file
  '***  if you like to log to the system event log,
  '***  use frmService.NTService1.LogEvent svcEventInformation, svcMessageInfo, strCommand
  
  Dim lngFileNum As Long
  
  lngFileNum = FreeFile()
  Open App.Path & SVCLOGFILE For Append As #lngFileNum
  Print #lngFileNum, Format$(Date$, "YYYY/MM/DD"), Format$(Time$, "HH:MM:SS"), strCommand
  Close #lngFileNum
End Sub

Public Sub Main()

'On Error GoTo ErrHandler

Set ObjService = New NTService.NTService

    ObjService.DisplayName = "test"
    ObjService.ServiceName = "testService"
            
    Select Case Trim$(Command$)
      
      '***  tell the OCX to install the service and quit
      Case "/install"
        '***  set all defaults for the service here
        With ObjService
          
          '***  True if the service needs to interact with the user
          .Interactive = False
         
          '***  use these to read / write to the registry at
          '***  HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\[SERVICE NAME]
          '.SaveSetting
          '.GetSetting
          '.DeleteSetting
          '.GetAllSettings
          
          '***  for example write the Description shown in the Services window.
           .SaveSetting "", "Description", "This is a Service written in VB6."
          
          '***  set the startmode to manual by default
          .StartMode = svcStartManual
          
          '***  now install the service
          .Install
          
          '***  write a line to the system log
          .LogEvent svcEventInformation, svcMessageInfo, "VB Service installed."
        End With
        
      '***  tell the OCX to uninstall the service and quit
      Case "/uninstall"
        ObjService.Uninstall
        
      '***  start the service. simply keep the form loaded
      Case ""
        ObjService.StartService
        
      '***  show a messagebox to show the commands.
      '***  for your final application, consider removing this.
      '***  better write to the NT event log.
      Case Else
        MsgBox "use " & App.EXEName & " /uninstall or /install..." & vbNewLine & _
        "use 'Net Start " & ObjService.ServiceName & "' to START the service" & vbNewLine & _
        "use 'Net Stop " & ObjService.ServiceName & "' to STOP the service" & vbNewLine & _
        "use the Windows Services to set the Startup Type to AUTOMATIC."
    
    End Select
   
    ServiceTime
        

End Sub

Private Function TimerProc(ByVal hwnd As Long, _
           ByVal uMsg As Long, _
           ByVal idEvent As Long, _
           ByVal dwTime As Long)
           
           subLogCommand "[TIMER] ..just to demonstrate that the service is running..."
           'Debug.Print hwnd & "-----" & uMsg & "-----" & idEvent & "-----" & dwTime & "-----" & Time

End Function

George

 

[mattKnight]

oops, none of my above post really applies; you aren't using the code linked to by zarkon4

Take Care

Matt
If at first you don't succeed, skydiving is not for you.