最近遇到三个人问关于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
运行效果：
结束！