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

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

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

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

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

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

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

 1 Option Explicit
 2 Private Const MAX_CLIENT = 20 '最大连接数
 3 '启动初始化和按钮代码
 4 Private Sub Form_Load()
 5     Dim i As Long
 6     For i = 1 To MAX_CLIENT
 7         Load SCK(i) '预加载
 8     Next i
 9 End Sub
10 Private Sub 关闭服务_Click()
11     Dim i As Long
12     For i = 0 To MAX_CLIENT
13         If SCK(i).State <> sckClosed Then SCK(i).Close
14     Next i
15     关闭服务.Enabled = False
16 End Sub
17 Private Sub 启动服务_Click()
18     On Error GoTo errline
19     SCK(0).LocalPort = 80 '监听80端口,如果被占用,就改其他的,浏览器访问就需要127.0.0.1:8080的形式
20     SCK(0).Listen
21     启动服务.Enabled = False
22     关闭服务.Enabled = True
23     Exit Sub
24 errline:
25     Call ErrCatch
26 End Sub
27 '连接请求处理
28 Private Sub SCK_ConnectionRequest(Index As Integer, ByVal requestID As Long)
29     Dim i As Long
30     For i = 1 To MAX_CLIENT
31         '如果winsock不处于"正在连接"和"已连接状态",就使用
32         If SCK(i).State <> sckConnected And SCK(i).State <> sckConnecting Then
33             If SCK(i).State <> sckClosed Then SCK(i).Close
34             SCK(i).Accept requestID
35         End If
36     Next i
37 End Sub
38 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)
39     Call ErrCatch
40     SCK(Index).Close
41 End Sub
42 Private Sub SCK_SendComplete(Index As Integer)
43     Showlog "发送完成!"
44     SCK(Index).Close
45 End Sub
46 '接收处理
47 Private Sub SCK_DataArrival(Index As Integer, ByVal bytesTotal As Long)
48     Dim s As String
49     SCK(Index).GetData s
50     Dim urls() As String
51     Dim txt As String
52     urls = PickUrl(s)
53     If UBound(urls) = 0 Then
54         txt = "欢迎访问,这是来自WebServer的内容!"
55     Else
56         Select Case urls(1)
57             Case "time": txt = "北京时间:" & Now
58             Case "ip": txt = "您的IP是:" & SCK(Index).RemoteHostIP
59             Case "test": txt = Replace(s, vbCrLf, "<BR />")
60             Case Else: txt = "欢迎访问,这是来自WebServer的内容!"
61         End Select
62     End If
63     SCK(Index).SendData Response(txt)
64 End Sub
65 'HTTP头响应头和内容的组装
66 Private Function Response(content As String) As String
67     Dim html As String
68     Dim b() As Byte
69     b = StrConv(content, vbFromUnicode)
70     html = html & "HTTP/1.1 200 OK" & vbCrLf
71     html = html & "Content-Type: text/html; charset=gb2312" & vbCrLf
72     html = html & "Connection: keep-alive" & vbCrLf
73     html = html & "Server: VB-WebServer" & vbCrLf
74     html = html & "Content-Length: " & (UBound(b) + 1) & vbCrLf & vbCrLf
75     html = html & content & vbCrLf
76     Response = html
77 End Function
78 '提取请求URL的目录组成
79 Private Function PickUrl(request As String) As String()
80     Dim i As Long
81     Dim j As Long
82     Dim s As String
83     i = InStr(request, " ")
84     j = InStr(i + 1, request, " ")
85     s = Mid(request, i + 1, j - i - 1)
86     Showlog "收到:" & s
87     PickUrl = Split(s, "/")
88 End Function
89 '异常输出
90 Private Sub ErrCatch()
91     Showlog "异常" & Err.Number & "," & Err.Description
92 End Sub
93 '显示日志
94 Private Sub Showlog(msg As String)
95     Text1.Text = Text1.Text & msg & vbCrLf
96     Text1.SelStart = Len(Text1.Text)
97 End Sub

View Code

运行效果：

结束！

转载于:https://www.cnblogs.com/xiii/p/7007531.html