CoderHelper如何实现为用户提供的简单的纯HTML站点服务器?
以下代码为关键代码.其它代码将不贴出.以下代码取自另外一程序员的代码.按照CoderHelper的需要.做出了更改.该程序员没有给出版权标识或者MysticBoy目前无法知道该代码出自那位程序员.牵扯版权问题.与MysticBoy无关.
Private Sub sckWS_Close(Index As Integer)
sckWS(Index).Close
End Sub
Private Sub sckWS_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next
Dim n As Long
If Me.cbsXianzhi.Value = 1 Then
If Me.obtCant.Value = True Then
For n = 0 To Me.lstCant.ListCount - 1
If sckWS(ttlConnections).RemoteHostIP = Me.lstCant.List(n) Then
Addlog "拒绝访问IP" & Me.lstCant.List(n), "IpCant"
List1.AddItem "拒绝访问IP" & Me.lstCant.List(n), "IpCant"
Exit Sub
End If
Next
ElseIf Me.optCan.Value = True Then
For n = 0 To Me.lstCan.ListCount - 1
If sckWS(ttlConnections).RemoteHostIP = Me.lstCan.List(n) Then
Addlog "允许访问IP" & Me.lstCan.List(n), "IpCan"
List1.AddItem "允许访问IP" & Me.lstCan.List(n), "IpCan"
Exit For
End If
Next
Exit Sub
End If
End If
DoEvents
DoEvents
DoEvents
List1.ListIndex = List1.ListCount - 1
DoEvents
ttlConnections = ttlConnections + 1 'add 1 to the total # of connections
numConnections = numConnections + 1 'number of connected clients + 1
If Me.chkCountIP.Value = 1 Then Addlog "当前连接数" & numConnections & "总数" & ttlConnections
Me.sst.TrayToolTip = "当前连接用户数量" & numConnections
DoEvents
DoEvents
If Me.chkCountIP.Value = 1 Then cIni.WriteValue "Count", "当前连接数" & numConnections & "总数" & ttlConnections, Year(Now) & Month(Now) & Day(Now)
If numConnections = maxConnections Then GoTo done 'if we've reached the max # of connections, exit sub.
Load sckWS(ttlConnections) 'load a new instance of sckWS.
DoEvents
DoEvents
DoEvents
sckWS(ttlConnections).LocalPort = 0 'set its local port to 0
sckWS(ttlConnections).Accept requestID 'Accept the connection request.
DoEvents
DoEvents
List1.AddItem sckWS(ttlConnections).RemoteHostIP & " 已连接"
DoEvents
DoEvents
List1.ListIndex = List1.ListCount - 1
done:
If Me.chkRecIP.Value = 1 Then Addlog sckWS(ttlConnections).RemoteHostIP & " 已连接"
If List1.ListCount >= 255 Then List1.RemoveItem 0
numConnections = numConnections - 1 'number of connections at the moment - 1
List1.ListIndex = List1.ListCount - 1
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
End Sub
Public Sub sSendData(id As Long, Data)
sckWS(id).SendData Data
DoEvents
DoEvents
DoEvents
End Sub
Private Sub sckWS_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
sckWS(Index).GetData strdata$ 'Get any data sent to us
'MsgBox strdata$ ' I used this for debugging
Debug.Print strdata$
DoEvents
If Mid$(strdata$, 1, 3) = "GET" Then 'If it is trying to get a site, find out
findget = InStr(strdata$, "GET ") ' the site they want then set requestedPage$
spc2 = InStr(findget + 5, strdata$, " ") ' to it.
pagetoget$ = Mid$(strdata$, findget + 4, spc2 - (findget + 4))
requestedPage$ = pagetoget$
Debug.Print requestedPage$
DoEvents
DoEvents
DoEvents '
List1.AddItem "请求文件: " & requestedPage$
If requestedPage$ = "/" Then
requestedPage$ = Me.cmIndexPage.Text '如果没有任何请求.那么给出该目录下的index.html文件,即给出索引文件.
Else
requestedPage$ = Mid(requestedPage$, InStr(requestedPage$, "/") + 1)
End If
DoEvents
Dim id As Long
id = ttlConnections
If Me.chkRecFile.Value = 1 Then Addlog "请求文件: " & requestedPage$
Debug.Print requestedPage$
DoEvents
If FileIsOK(Me.txtRoot + "\" + requestedPage$) Then
DoEvents
Dim dats() As Byte
dats = LoadBinFile(CheckPath(Me.txtRoot.Text) + requestedPage$)
sckWS(ttlConnections).SendData dats
DoEvents
ReDim dats(0) As Byte
DoEvents
DoEvents
ElseIf requestedPage = "104" Then
sSendData id, LoadResString(104)
DoEvents
DoEvents
List1.AddItem sckWS(id).RemoteHostIP & "请求超时!"
List1.ListIndex = List1.ListCount - 1
DoEvents
Else
sckWS(ttlConnections).SendData Replace(LoadResString(101), "&file&", requestedPage)
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
Addlog sckWS(ttlConnections).RemoteHostIP & "无法找到请求的文件" & requestedPage
List1.AddItem sckWS(id).RemoteHostIP & "请求的文件无法找到!"
List1.ListIndex = List1.ListCount - 1
End If
DoEvents
ElseIf Mid$(strdata$, 1, 4) = "POST" Then 'This is the code when it is trying to post something!
findpost = InStr(strdata$, "POST ") 'the data where filtered in the ConnectionRequest
spc2 = InStr(findpost + 5, strdata$, " ") 'Function of the winsock control
pagetopost$ = Mid$(strdata$, findpost + 5, spc2 - (findpost + 5))
requestedPage$ = pagetopost$
Addlog "Post" & pagetopost$
End If
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
End Sub
Private Sub sckWS_SendComplete(Index As Integer)
'This was a bug that was fixed from v.2a.
If requestedPage$ <> "" Then 'f the requested page doesn't = nothing then...
requestedPage$ = "" 'clear the requestedPage varible.
List1.AddItem sckWS(ttlConnections).RemoteHostIP & "已关闭!"
DoEvents
End If
sckWS(ttlConnections).Close 'Close the connection.
Addlog sckWS(ttlConnections).RemoteHostIP & "已关闭!"
DoEvents
End Sub
Private Sub sckWS_SendProgress(Index As Integer, ByVal bytesSent As Long, ByVal bytesRemaining As Long)
lblNow.Caption = sckWS(Index).RemoteHostIP & ":已发送" & bytesSent & "剩下:" & bytesRemaining
DoEvents
End Sub
