VB开发类似IIS简易的WebServer,代码不到100行

最近遇到三个人问关于VB写网页服务器的问题，所以今天抽时间写一下，演示其实没有多复杂。

代码里自定义的方法只有四个，没有公共变量绕来绕去，该注释的也都注释了。

想扩展更复杂的功能，就需要自己补脑HTTP协议。

新建一个VB工程，界面及控件如下：

文本框控件名不变，两个按钮的Name分别是 启动服务 和 关闭服务。然后粘贴以下代码进去：

（↓↓↓点+展开代码~.~）

 Option Explicit
 Private Const MAX_CLIENT =  '最大连接数
 '启动初始化和按钮代码
 Private Sub Form_Load()
     Dim i As Long
     For i =  To MAX_CLIENT
         Load SCK(i) '预加载
     Next i
 End Sub
 Private Sub 关闭服务_Click()
     Dim i As Long
     For i =  To MAX_CLIENT
         If SCK(i).State <> sckClosed Then SCK(i).Close
     Next i
     关闭服务.Enabled = False
 End Sub
 Private Sub 启动服务_Click()
     On Error GoTo errline
     SCK().LocalPort =  '监听80端口,如果被占用,就改其他的,浏览器访问就需要127.0.0.1:8080的形式
     SCK().Listen
     启动服务.Enabled = False
     关闭服务.Enabled = True
     Exit Sub
 errline:
     Call ErrCatch
 End Sub
 '连接请求处理
 Private Sub SCK_ConnectionRequest(Index As Integer, ByVal requestID As Long)
     Dim i As Long
     For i =  To MAX_CLIENT
         '如果winsock不处于"正在连接"和"已连接状态",就使用
         If SCK(i).State <> sckConnected And SCK(i).State <> sckConnecting Then
             If SCK(i).State <> sckClosed Then SCK(i).Close
             SCK(i).Accept requestID
         End If
     Next i
 End Sub
 Private Sub SCK_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
     Call ErrCatch
     SCK(Index).Close
 End Sub
 Private Sub SCK_SendComplete(Index As Integer)
     Showlog "发送完成!"
     SCK(Index).Close
 End Sub
 '接收处理
 Private Sub SCK_DataArrival(Index As Integer, ByVal bytesTotal As Long)
     Dim s As String
     SCK(Index).GetData s
     Dim urls() As String
     Dim txt As String
     urls = PickUrl(s)
     If UBound(urls) =  Then
         txt = "欢迎访问,这是来自WebServer的内容!"
     Else
         Select Case urls()
             Case "time": txt = "北京时间:" & Now
             Case "ip": txt = "您的IP是:" & SCK(Index).RemoteHostIP
             Case "test": txt = Replace(s, vbCrLf, "<BR />")
             Case Else: txt = "欢迎访问,这是来自WebServer的内容!"
         End Select
     End If
     SCK(Index).SendData Response(txt)
 End Sub
 'HTTP头响应头和内容的组装
 Private Function Response(content As String) As String
     Dim html As String
     Dim b() As Byte
     b = StrConv(content, vbFromUnicode)
     html = html & "HTTP/1.1 200 OK" & vbCrLf
     html = html & "Content-Type: text/html; charset=gb2312" & vbCrLf
     html = html & "Connection: keep-alive" & vbCrLf
     html = html & "Server: VB-WebServer" & vbCrLf
     html = html & "Content-Length: " & (UBound(b) + ) & vbCrLf & vbCrLf
     html = html & content & vbCrLf
     Response = html
 End Function
 '提取请求URL的目录组成
 Private Function PickUrl(request As String) As String()
     Dim i As Long
     Dim j As Long
     Dim s As String
     i = InStr(request, " ")
     j = InStr(i + , request, " ")
     s = Mid(request, i + , j - i - )
     Showlog "收到:" & s
     PickUrl = Split(s, "/")
 End Function
 '异常输出
 Private Sub ErrCatch()
     Showlog "异常" & Err.Number & "," & Err.Description
 End Sub
 '显示日志
 Private Sub Showlog(msg As String)
     Text1.Text = Text1.Text & msg & vbCrLf
     Text1.SelStart = Len(Text1.Text)
 End Sub

运行效果：

结束！