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
I never ran into the problem of arrays of withevents objects, and your solution is creative and no doubt effective.