之前用VBS写过一个，效率和支持比较low，这次闲着没事用VB重写了一次。
当前的实现版本仅支持静态文件的访问（*.html之类），支持访问方式为GET，HTTP状态支持200和404。
两个文件，一个是定义了常用到的函数的模块tools.bas
1 'tools.bas 2 Private Declare Function GetTickCount Lib "kernel32" () As Long 3 Public Const WEB_ROOT As String = "c:web" 4 Public req_types As Object 5 6 Public Function GetHeader(ByVal data As String, ByVal idex As Integer) As Object 7 'head [dictionary objet]: 8 ' Request, [dictionary objet] <Method|File|Protocol> 9 ' Host, [string] 10 ' Accept-Language, [string] 11 ' *etc 12 Set head = CreateObject("scripting.dictionary") 13 Set rqst = CreateObject("scripting.dictionary") 14 Call head.Add("RemoteHost", Form1.SckHandler(idex).RemoteHostIP) 15 Call head.Add("RemotePort", Form1.SckHandler(idex).RemotePort) 16 temp = Split(data, vbCrLf) 17 'request's method, file and protocol 18 rmfp = Split(temp(0), " ") 19 Call rqst.Add("Method", rmfp(0)) 20 Call rqst.Add("File", rmfp(1)) 21 Call rqst.Add("Protocol", rmfp(2)) 22 Call head.Add("Request", rqst) 23 For idex = 1 To UBound(temp) 24 If temp(idex) <> "" Then 25 prop = Split(temp(idex), ": ") 26 Call head.Add(prop(0), prop(1)) 27 End If 28 Next 29 Set GetHeader = head 30 End Function 31 32 Public Sub Sleep(ByVal dwDelay As Long) 33 limt = GetTickCount() + dwDelay 34 Do While GetTickCount < limt 35 DoEvents 36 Loop 37 End Sub 38 39 Function URLDecode(ByVal url As String) As String 40 'using the function [decodeURI] from js 41 Set js = CreateObject("scriptcontrol") 42 js.language = "javascript" 43 URLDecode = js.eval("decodeURI('" & url & "')") 44 Set js = Nothing 45 End Function 46 47 Public Function GetGMTDate() As String 48 Dim WEEKDAYS 49 Dim MONTHS 50 Dim DEFAULT_PAGE 51 52 WEEKDAYS = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") 53 MONTHS = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sept", "Oct", "Nov", "Dec") 54 DEFAULT_PAGE = Array("index.html", "index.htm", "main.html", "main.htm") 55 date_ = DateAdd("h", -8, Now()) 56 weekday_ = WEEKDAYS(Weekday(date_) - 1) 57 month_ = MONTHS(Month(date_) - 1) 58 day_ = Day(date_): year_ = Year(date_) 59 time_ = Right(date_, 8) 60 If Hour(time_) < 10 Then time_ = "0" & time_ 61 GetGMTDate = weekday_ & ", " & day_ & _ 62 " " & month_ & " " & year_ & _ 63 " " & time_ & " GMT" 64 End Function 65 66 Public Function url2file(ByVal url As String) As String 67 file = URLDecode(url) 68 '默认文件为 index.html 69 If file = "/" Then file = "/index.html" 70 file = Replace(file, "/", "") 71 file = WEB_ROOT & file 72 url2file = file 73 End Function 74 75 Public Function GetBytes(ByVal file As String, ByRef byts() As Byte) As Long 76 'not supported big file which size>2G 77 fnum = FreeFile() 78 Open file For Binary Access Read As #fnum 79 size = LOF(fnum) 80 If size = 0 Then 81 byts = vbCrLf 82 Else 83 ReDim byts(size - 1) As Byte 84 Get #fnum, , byts 85 End If 86 Close #fnum 87 GetBytes = size 88 End Function 89 90 Public Function SetResponseHeader(ByVal file As String, ByVal size As Long) As String 91 'get the content-type from extension, 92 ' if file has not ext, then set it to .* 93 If InStr(file, ".") = 0 Then file = file & ".*" 94 ext = "." & Split(file, ".")(1) 95 ftype = req_types(ext) 96 header = "HTTP/1.1 200 OK" & vbCrLf & _ 97 "Server: http-vb/0.1 vb/6.0" & vbCrLf & _ 98 "Date: " & GetGMTDate() & vbCrLf & _ 99 "Content-Type: " & ftype & vbCrLf & _ 100 "Content-Length: " & size & vbCrLf & vbCrLf 101 SetResponseHeader = header 102 End Function
然后是窗体部分，目前日志全部都用的Debug打印的，因此就没专门来写日志输出：
1 'code by lichmama 2 'winsock 状态常数 3 Private Enum WINSOCK_STATE_ENUM 4 sckClosed = 0 '关闭状态 5 sckOpen = 1 '打开状态 6 sckListening = 2 '侦听状态 7 sckConnectionPending = 3 '连接挂起 8 sckResolvingHost = 4 '解析域名 9 sckHostResolved = 5 '已识别主机 10 sckConnecting = 6 '正在连接 11 sckConnected = 7 '已连接 12 sckClosing = 8 '同级人员正在关闭连接 13 sckError = 9 '错误 14 End Enum 15 16 Private Sub Command1_Click() 17 '启动监听 18 Call Winsock1.Listen 19 Me.Caption = "HTTP-SERVER/VB： HTTP服务启动，监听端口80" 20 End Sub 21 22 Private Sub Command2_Click() 23 '关闭监听 24 Call Winsock1.Close 25 For i = 0 To 9 26 Call SckHandler(i).Close 27 Next 28 Me.Caption = "HTTP-SERVER/VB： HTTP服务已停止" 29 End Sub 30 31 Private Sub Form_Load() 32 '当前支持的文件类型 33 Set req_types = CreateObject("scripting.dictionary") 34 Call req_types.Add(".html", "text/html") 35 Call req_types.Add(".htm", "text/html") 36 Call req_types.Add(".xml", "text/xml") 37 Call req_types.Add(".js", "application/x-javascript") 38 Call req_types.Add(".css", "text/css") 39 Call req_types.Add(".txt", "text/plain") 40 Call req_types.Add(".jpg", "image/jpeg") 41 Call req_types.Add(".png", "image/image/png") 42 Call req_types.Add(".gif", "image/image/gif") 43 Call req_types.Add(".ico", "image/image/x-icon") 44 Call req_types.Add(".bmp", "application/x-bmp") 45 Call req_types.Add(".*", "application/octet-stream") 46 47 For i = 1 To 9 48 Call Load(SckHandler(i)) 49 With SckHandler(i) 50 .Protocol = sckTCPProtocol 51 .LocalPort = 80 52 .Close 53 End With 54 Next 55 56 With Winsock1 57 .Protocol = sckTCPProtocol 58 .Bind 80, "0.0.0.0" 59 .Close 60 End With 61 End Sub 62 63 Private Sub Form_Unload(Cancel As Integer) 64 Winsock1.Close 65 For i = 0 To 9 66 SckHandler(i).Close 67 Next 68 End Sub 69 70 Private Sub SckHandler_DataArrival(Index As Integer, ByVal bytesTotal As Long) 71 Dim buff As String 72 Call SckHandler(Index).GetData(buff, vbString, bytesTotal) 73 Call Handle_Request(buff, Index) 74 End Sub 75 76 Private Sub SckHandler_SendComplete(Index As Integer) 77 Call SckHandler(Index).Close 78 End Sub 79 80 Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long) 81 HANDLER_ENTRANCE_: 82 For i = 0 To 9 83 If SckHandler(i).State <> sckConnected And _ 84 SckHandler(i).State <> sckConnecting And _ 85 SckHandler(i).State <> sckClosing Then 86 Call SckHandler(i).Accept(requestID) 87 Exit Sub 88 End If 89 Next 90 '如果未找到空闲的handler，等待100ms后，继续寻找 91 Call Sleep(100): GoTo HANDLER_ENTRANCE_ 92 End Sub 93 94 Private Sub Handle_Request(ByVal req As String, ByVal HandlerId As Integer) 95 Dim byts() As Byte 96 Set head = GetHeader(req, HandlerId) 97 98 file = url2file(head("Request")("File")) 99 fnme = Dir(file) 100 If fnme <> "" Then 101 size = GetBytes(file, byts) 102 SckHandler(HandlerId).SendData SetResponseHeader(file, size) 103 SckHandler(HandlerId).SendData byts 104 Erase byts 105 Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _ 106 head("Request")("File") & " " & _ 107 head("Request")("Protocol"); " " & _ 108 head("RemoteHost") & ":" & head("RemotePort") & " " & _ 109 "-- 200 OK" 110 Else 111 page404 = "<!DOCTYPE html><html><head><title>404错误 - HTTP_VB(@lichmama)</title><body><br><p style='text-align:center;font-family:consolas'>""don't busy on trying, maybe you just took a wrong way of opening.""<br> -- kindly tip from <i style='color:red;font-size:32px'>404</i></p></body></head></html>" 112 SckHandler(HandlerId).SendData "HTTP/1.1 404 NOT FOUND" & vbCrLf & _ 113 "Server: http-vb/0.1 vb/6.0" & vbCrLf & _ 114 "Date: " & GetGMTDate() & vbCrLf & _ 115 "Content-Length: " & Len(page404) & vbCrLf & vbCrLf 116 SckHandler(HandlerId).SendData page404 117 Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _ 118 head("Request")("File") & " " & _ 119 head("Request")("Protocol"); " " & _ 120 head("RemoteHost") & ":" & head("RemotePort") & " " & _ 121 "-- 404 NOT FOUND" 122 End If 123 124 Set head("Request") = Nothing 125 Set head = Nothing 126 End Sub
最后上两张图，后台：
404：
正常访问：
