新生命Web服务器v1.1源码

Dim httpd
Dim retVal

Dim ServiceName
Dim DisplayName

ServiceName = "NewLifeWebServer"
DisplayName = "新生命页面应用开发专用Web服务器"

'Shell.Service.RunService "NLWeb", "新生命专用Web服务器,80端口,支持ASP", "新生命页面应用开发专用"

Shell.Service.Name = ServiceName
Shell.Service.DisplayName  = DisplayName & " 作者 大石头 http://www.nnhy.org"
Shell.Service.Description  = DisplayName

If Shell.Service.Running then
 retVal = Shell.MsgBox("本程序的另一个副本已启动，是否强制终止？", DisplayName, vbOKCancel)
 If retVal = 2 then
     Shell.Quit 0
   End If
 Shell.Service.SendCommand 200 '发送终止指令
 NewLife.Sleep 1000 '等待终止
End If

Shell.Service.RunService ServiceName

'---------------------- Service Event ---------------------

Sub OnServiceStart()
 Shell.Service.AppendCommand 101, "开始服务"
 Shell.Service.AppendCommand 102, "暂停服务"
 Shell.Service.AppendCommand 103, "重启服务"
 Shell.Service.AppendCommand -1
 Shell.Service.AppendCommand 0, "打开主页"
 Shell.Service.AppendCommand 104, "作者介绍"

    Set httpd = NetBox.CreateObject("NetBox.HttpServer")

    If httpd.Create("", 80) <> 0 Then
     Shell.Beep
  Dim retVal
  retVal = Shell.MsgBox("端口可能已经被IIS占用，是否停止IIS？", DisplayName, vbOKCancel)
  If retVal = 2 then
         Shell.Quit 0
       End If
       Shell.Execute "Net Stop W3SVC", 16
  If httpd.Create("", 80) <> 0 Then
   Shell.Beep
   Shell.MsgBox "很抱歉，Web服务无法启动！", DisplayName
         Shell.Quit 0
       End If
 End If
 
    Set host = httpd.AddHost("", "")

    host.EnableScript = true
    host.EnableBrowse = true
 host.EnableDebug = true
    host.AddDefault "index.asp"
    host.AddDefault "index.htm"
    host.AddDefault "index.html"
    host.AddDefault "default.asp"
    host.AddDefault "default.htm"
    host.AddDefault "default.html"

    httpd.Start
   
    Dim RndForOpenNnhyOrg '百分之一的概率打开http://www.nnhy.org
    Randomize
    RndForOpenNnhyOrg = Int((100 * Rnd) + 1)   ' 产生 1 到 100 之间的随机数。
    If RndForOpenNnhyOrg = 1 Then OpenUrl "http://www.nnhy.org"
End Sub

Sub OnServiceStop()
    httpd.Close
End Sub

Sub OnServicePause()
    httpd.Stop
End Sub

Sub OnServiceResume()
    httpd.Start
End Sub

Sub OnServiceCommand(uCtrl)
 'Shell.MsgBox "被迫退出" & uCtrl, "nnhy"
 Select Case uCtrl
  'Case 3 '开始服务
   '   Shell.MsgBox "开始服务", "nnhy"
   '   httpd.Start
  'Case 2 '暂停服务
   '   Shell.MsgBox "暂停服务", "nnhy"
   '   httpd.Stop
  'Case 16 '重启服务
   '   Shell.MsgBox "重启服务", "nnhy"
   '   httpd.Close
  Case 101 '开始服务
      httpd.Start
  Case 102 '暂停服务
      httpd.Stop '停止服务器运行将暂停接受新的连接请求，对于已经建立的连接没有影响。
  Case 103 '重启服务
      httpd.Close '关闭服务器对象将关闭所有已经建立的连接，等待正在处理的连接线程全部结束，并清除服务器所占用的资源。
      Shell.Execute NewLife.ApplicationName
      Shell.Halt 0
  Case 104 '打开http://www.nnhy.org
   OpenUrl "http://www.nnhy.org"
  Case 200
   httpd.Close
   'Shell.MsgBox "被迫退出", "nnhy"
   'Shell.Quit 0
   Shell.Halt 0
  Case else '打开主页
   OpenUrl "http://127.0.0.1"
 End Select
End Sub

Sub OpenUrl(url)
 Set htWin= CreateObject("NetBox.HtmlWindow")
 htWin.Title = Shell.Service.DisplayName
 htWin.ResizAble = false
 htWin.Center
 htWin.ScrollBar = false
 htWin.Open url
 htWin.ShowDialog
End Sub