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

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

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

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

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

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

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

Option Explicit
Private Const MAX_CLIENT = 20 '最大连接数
'启动初始化和按钮代码
Private Sub Form_Load()
    Dim i As Long
    For i = 1 To MAX_CLIENT
        Load SCK(i) '预加载
    Next i
End Sub
Private Sub 关闭服务_Click()
    Dim i As Long
    For i = 0 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(0).LocalPort = 80 '监听80端口,如果被占用,就改其他的,浏览器访问就需要127.0.0.1:8080的形式
    SCK(0).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 = 1 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) = 0 Then
        txt = "欢迎访问,这是来自WebServer的内容!"
    Else
        Select Case urls(1)
            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) + 1) & 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 + 1, request, " ")
    s = Mid(request, i + 1, j - i - 1)
    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

运行效果：

结束！