NTSVC示例

Option Explicit

Private m_blnStopService As Boolean    '服务是否已终止

Private Sub Form_Load()
On Error GoTo ERRPROC
Label1.Caption = "Loading"
NTService.DisplayName = "Sample NT Service" '服务管理器中的显示名称
NTService.ServiceName = "SampleService"    '服务管理器中的服务名称
'安装服务
If Command = "/i" Then
       NTService.Interactive = True     '启用与桌面交互
       '*********************************************************************************************************
       '**“允许服务与桌面交互"指的是该服务提供某些交互界面，通过这些界面接受用户的某些设置，接收键盘鼠标消息等等
       '** 然后该服务再根据用户输入的信息来配置服务如何运行，那么必须选中“允许服务与桌面交互”.
       '** 一般情况下，不推荐“服务与桌面交互”，因为会带来一些隐患。
       '*********************************************************************************************************
       '作为 NT 服务安装程序
       '三种模式
       'svcStartAutomatic   自动
       'svcStartDisabled 禁用
       'svcStartManual     手动
       NTService.StartMode = svcStartAutomatic
       '读取安装状态
       If NTService.Install Then
         '在注册表中保存在 TimerInterval 参数
         '[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\SampleService\Parameters]
         '"TimerInterval"=hex(2):33,00,30,00,30,00,00,00
         NTService.SaveSetting "Parameters", "TimerInterval", "300"
         MsgBox NTService.DisplayName & ": 成功安装"
       Else
         MsgBox NTService.DisplayName & ": 安装失败"
       End If
       End
       '删除服务注册表项并卸载服务
ElseIf Command = "/u" Then
       If NTService.Uninstall Then
         MsgBox NTService.DisplayName & ": 卸载成功"
       Else
         MsgBox NTService.DisplayName & ": 卸载失败"
       End If
       End
ElseIf Command <> "" Then
       MsgBox "无效的参数"
       End
End If
'TimerInterval存储的值为计时器时间间隔
Timer.Interval = CInt(NTService.GetSetting("Parameters", "TimerInterval", "300"))
'enable Pause/Continue. Must be set before StartService
'is called or in design mode
'启用暂停/继续。必须在StartService属性为之前或在设计模式中
'服务管理器的服务状态按钮下有四个按钮的有效性
'启动/停止/暂停/恢复
NTService.ControlsAccepted = svcCtrlPauseContinue
'服务连接到Windows NT服务控制器
NTService.StartService
Exit Sub
ERRPROC:
Call NTService.LogEvent(svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description)
End Sub

'卸载该服务
Private Sub Form_Unload(Cancel As Integer)
'如果服务在运行中
If Not m_blnStopService Then
       If MsgBox("Are you sure you want to unload the service?..." & vbCrLf & "the service will be stopped", vbQuestion + vbYesNo, "Stop Service") = vbYes Then
         NTService.StopService
         Label1.Caption = "Stopping"
         Cancel = True
       Else
         Cancel = True
       End If
End If
End Sub

Private Sub NTService_Continue(Success As Boolean)
'处理继续服务事件
On Error GoTo ERRPROC
Timer.Enabled = True
Label1.Caption = "Running"
Success = True
NTService.LogEvent svcEventInformation, svcMessageInfo, "Service continued"
Exit Sub
ERRPROC:
NTService.LogEvent svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description
End Sub

Private Sub NTService_Control(ByVal mEvent As Long)
'控制服务事件
On Error GoTo ERRPROC
Label1.Caption = NTService.DisplayName & " Control signal " & CStr([mEvent])
Exit Sub
ERRPROC:
NTService.LogEvent svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description
End Sub

Private Sub NTService_Pause(Success As Boolean)
'暂停事件请求
On Error GoTo ERRPROC
Timer.Enabled = False
Label1.Caption = "Paused"
NTService.LogEvent svcEventError, svcMessageError, "Service paused"
Success = True
Exit Sub
ERRPROC:
NTService.LogEvent svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description
End Sub

Private Sub NTService_Start(Success As Boolean)
'启动事件请求
On Error GoTo ERRPROC
Label1.Caption = "Running"
Success = True
Exit Sub
ERRPROC:
NTService.LogEvent svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description
End Sub

Private Sub NTService_Stop()
'停止并终止服务
On Error GoTo ERRPROC
Label1.Caption = "Stopped"
m_blnStopService = True
Unload Me
ERRPROC:
NTService.LogEvent svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description
End Sub

Private Sub Timer_Timer()
'当服务启动后运行这个过程
Dim sngX As Single
Dim sngY As Single
On Error GoTo ERRPROC
sngX = Me.Left + Rnd() * 100 - 50 '窗体左右晃动
sngY = Me.Top + Rnd() * 100 - 50
If sngY < 0 Then sngY = 0           '保证程序不出屏幕左上角
If sngX < 0 Then sngX = 0
If sngX > Screen.Width - Width Then sngX = Screen.Width - Width
If sngY > Screen.Height - Height Then sngY = Screen.Height - Height   '保证程序不出屏幕右下角
Me.Move sngX, sngY
Exit Sub
ERRPROC:
NTService.LogEvent svcMessageError, svcEventError, "[" & Err.Number & "] " & Err.Description
End Sub