之前用VBS写过一个，效率和支持比较low，这次闲着没事用VB重写了一次。
当前的实现版本仅支持静态文件的访问（*.html之类），支持访问方式为GET，HTTP状态支持200和404。
两个文件，一个是定义了常用到的函数的模块tools.bas
1 'tools.bas
'tools.bas
Private Declare Function GetTickCount Lib "kernel32" () As Long
Public Const WEB_ROOT As String = "c:\web"
Public req_types As Object
Public Function GetHeader(ByVal data As String, ByVal idex As Integer) As Object
'head [dictionary objet]:
' Request, [dictionary objet] <Method|File|Protocol>
' Host, [string]
' Accept-Language, [string]
' *etc
Set head = CreateObject("scripting.dictionary")
Set rqst = CreateObject("scripting.dictionary")
Call head.Add("RemoteHost", Form1.SckHandler(idex).RemoteHostIP)
Call head.Add("RemotePort", Form1.SckHandler(idex).RemotePort)
temp = Split(data, vbCrLf)
'request's method, file and protocol
rmfp = Split(temp(0), " ")
Call rqst.Add("Method", rmfp(0))
Call rqst.Add("File", rmfp(1))
Call rqst.Add("Protocol", rmfp(2))
Call head.Add("Request", rqst)
For idex = 1 To UBound(temp)
If temp(idex) <> "" Then
prop = Split(temp(idex), ": ")
Call head.Add(prop(0), prop(1))
End If
Next
Set GetHeader = head
End Function
Public Sub Sleep(ByVal dwDelay As Long)
limt = GetTickCount() + dwDelay
Do While GetTickCount < limt
DoEvents
Loop
End Sub
Function URLDecode(ByVal url As String) As String
'using the function [decodeURI] from js
Set js = CreateObject("scriptcontrol")
js.language = "javascript"
URLDecode = js.eval("decodeURI('" & url & "')")
Set js = Nothing
End Function
Public Function GetGMTDate() As String
Dim WEEKDAYS
Dim MONTHS
Dim DEFAULT_PAGE
WEEKDAYS = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
MONTHS = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sept", "Oct", "Nov", "Dec")
DEFAULT_PAGE = Array("index.html", "index.htm", "main.html", "main.htm")
date_ = DateAdd("h", -8, Now())
weekday_ = WEEKDAYS(Weekday(date_) - 1)
month_ = MONTHS(Month(date_) - 1)
day_ = Day(date_): year_ = Year(date_)
time_ = Right(date_, 8)
If Hour(time_) < 10 Then time_ = "0" & time_
GetGMTDate = weekday_ & ", " & day_ & _
" " & month_ & " " & year_ & _
" " & time_ & " GMT"
End Function
Public Function url2file(ByVal url As String) As String
file = URLDecode(url)
'默认文件为 index.html
If file = "/" Then file = "/index.html"
file = Replace(file, "/", "\")
file = WEB_ROOT & file
url2file = file
End Function
Public Function GetBytes(ByVal file As String, ByRef byts() As Byte) As Long
'not supported big file which size>2G
fnum = FreeFile()
Open file For Binary Access Read As #fnum
size = LOF(fnum)
If size = 0 Then
byts = vbCrLf
Else
ReDim byts(size - 1) As Byte
Get #fnum, , byts
End If
Close #fnum
GetBytes = size
End Function
Public Function SetResponseHeader(ByVal file As String, ByVal size As Long) As String
'get the content-type from extension,
' if file has not ext, then set it to .*
If InStr(file, ".") = 0 Then file = file & ".*"
ext = "." & Split(file, ".")(1)
ftype = req_types(ext)
header = "HTTP/1.1 200 OK" & vbCrLf & _
"Server: http-vb/0.1 vb/6.0" & vbCrLf & _
"Date: " & GetGMTDate() & vbCrLf & _
"Content-Type: " & ftype & vbCrLf & _
"Content-Length: " & size & vbCrLf & vbCrLf
SetResponseHeader = header
End Function然后是窗体部分，目前日志全部都用的Debug打印的，因此就没专门来写日志输出：
'code by lichmama
'winsock 状态常数
Private Enum WINSOCK_STATE_ENUM
sckClosed = 0 '关闭状态
sckOpen = 1 '打开状态
sckListening = 2 '侦听状态
sckConnectionPending = 3 '连接挂起
sckResolvingHost = 4 '解析域名
sckHostResolved = 5 '已识别主机
sckConnecting = 6 '正在连接
sckConnected = 7 '已连接
sckClosing = 8 '同级人员正在关闭连接
sckError = 9 '错误
End Enum
Private Sub Command1_Click()
'启动监听
Call Winsock1.Listen
Me.Caption = "HTTP-SERVER/VB： HTTP服务启动，监听端口80"
End Sub
Private Sub Command2_Click()
'关闭监听
Call Winsock1.Close
For i = 0 To 9
Call SckHandler(i).Close
Next
Me.Caption = "HTTP-SERVER/VB： HTTP服务已停止"
End Sub
Private Sub Form_Load()
'当前支持的文件类型
Set req_types = CreateObject("scripting.dictionary")
Call req_types.Add(".html", "text/html")
Call req_types.Add(".htm", "text/html")
Call req_types.Add(".xml", "text/xml")
Call req_types.Add(".js", "application/x-javascript")
Call req_types.Add(".css", "text/css")
Call req_types.Add(".txt", "text/plain")
Call req_types.Add(".jpg", "image/jpeg")
Call req_types.Add(".png", "image/image/png")
Call req_types.Add(".gif", "image/image/gif")
Call req_types.Add(".ico", "image/image/x-icon")
Call req_types.Add(".bmp", "application/x-bmp")
Call req_types.Add(".*", "application/octet-stream")
For i = 1 To 9
Call Load(SckHandler(i))
With SckHandler(i)
.Protocol = sckTCPProtocol
.LocalPort = 80
.Close
End With
Next
With Winsock1
.Protocol = sckTCPProtocol
.Bind 80, "0.0.0.0"
.Close
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
Winsock1.Close
For i = 0 To 9
SckHandler(i).Close
Next
End Sub
Private Sub SckHandler_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim buff As String
Call SckHandler(Index).GetData(buff, vbString, bytesTotal)
Call Handle_Request(buff, Index)
End Sub
Private Sub SckHandler_SendComplete(Index As Integer)
Call SckHandler(Index).Close
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
HANDLER_ENTRANCE_:
For i = 0 To 9
If SckHandler(i).State <> sckConnected And _
SckHandler(i).State <> sckConnecting And _
SckHandler(i).State <> sckClosing Then
Call SckHandler(i).Accept(requestID)
Exit Sub
End If
Next
'如果未找到空闲的handler，等待100ms后，继续寻找
Call Sleep(100): GoTo HANDLER_ENTRANCE_
End Sub
Private Sub Handle_Request(ByVal req As String, ByVal HandlerId As Integer)
Dim byts() As Byte
Set head = GetHeader(req, HandlerId)
file = url2file(head("Request")("File"))
fnme = Dir(file)
If fnme <> "" Then
size = GetBytes(file, byts)
SckHandler(HandlerId).SendData SetResponseHeader(file, size)
SckHandler(HandlerId).SendData byts
Erase byts
Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _
head("Request")("File") & " " & _
head("Request")("Protocol"); " " & _
head("RemoteHost") & ":" & head("RemotePort") & " " & _
"-- 200 OK"
Else
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>"
SckHandler(HandlerId).SendData "HTTP/1.1 404 NOT FOUND" & vbCrLf & _
"Server: http-vb/0.1 vb/6.0" & vbCrLf & _
"Date: " & GetGMTDate() & vbCrLf & _
"Content-Length: " & Len(page404) & vbCrLf & vbCrLf
SckHandler(HandlerId).SendData page404
Debug.Print "[HTTP-VB]: " & head("Request")("Method") & " " & _
head("Request")("File") & " " & _
head("Request")("Protocol"); " " & _
head("RemoteHost") & ":" & head("RemotePort") & " " & _
"-- 404 NOT FOUND"
End If
Set head("Request") = Nothing
Set head = Nothing
End Sub最后上两张图，后台：
404：
正常访问：
