Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal _
hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, _
ByVal hpvSource&, ByVal cbCopy&)
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Private iCount As Integer
Private Function getip(name As String) As String
Dim hostent_addr As Long
Dim HOST As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String
hostent_addr = gethostbyname(name)
If hostent_addr = 0 Then
getip = "" '主机名不能被解释
Exit Function
End If
RtlMoveMemory HOST, hostent_addr, LenB(HOST)
RtlMoveMemory hostip_addr, HOST.hAddrList, 4
ReDim temp_ip_address(1 To HOST.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, HOST.hLength
For i = 1 To HOST.hLength
ip_address = ip_address & temp_ip_address(i) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
getip = ip_address
End Function
Private Sub Command1_Click()
wskServer.LocalPort = 8081
wskServer.Listen
Command1.Enabled = False
End Sub
Private Sub Winsock1_Error(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)
MsgBox Description, vbExclamation, "ERROR"
Winsock.Close
End Sub
Private Sub wskClent_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim bty() As Byte
ReDim bty(1 To bytesTotal) As Byte
Dim strHost As String
Dim strPort As String
Dim strdata As String
Dim strHeader As String
Dim pos As Integer
Dim strDataSend As String
Dim strPostData As String
'wskClent(Index).GetData bty, vbByte
'接收数据
wskClent(Index).GetData strdata, vbString
'这里把所有的内容都处理一次
Dim headdata() As String
'headdata = Split(Replace(Replace(strdata, vbCrLf, vbCr), vbCr & vbCr, vbCr), vbCr)
headdata = Split(strdata, vbCrLf)
For i = LBound(headdata) To UBound(headdata)
Dim jj As Boolean
jj = False
'主机地址
pos = InStr(1, UCase(headdata(i)), "HOST:")
If pos > 0 Then
Dim strhosttemp As String
strhosttemp = Trim(Mid(headdata(i), 6))
If InStr(1, strhosttemp, ":") Then
strPort = Right(strhosttemp, Len(strhosttemp) - InStr(1, strhosttemp, ":"))
strHost = Left(strhosttemp, InStr(1, strhosttemp, ":") - 1)
Else
strHost = strhosttemp
strPort = 80
End If
End If
'处理 请求地址
Dim action As String
pos = InStr(1, headdata(i), " ")
If pos > 0 Then
action = Trim(UCase(Left(headdata(i), pos)))
If action = "GET" Or action = "POST" Then
' If action = "POST" Then
' strPostData = headdata(UBound(headdata))
' End If
If InStr(4, UCase(headdata(i)), "HTTP") > 0 Then
pos = InStr(12, headdata(i), "/")
strDataSend = action & " " & Mid(headdata(i), pos)
Debug.Print action & " " & Mid(headdata(i), pos)
jj = True
End If
End If
End If
If UCase(Left(headdata(i), 6)) = "PROXY-" Then
jj = True
strDataSend = strDataSend & vbCrLf & "Connection: Keep-Alive"
End If
If (jj = False) Then
strDataSend = strDataSend & vbCrLf & headdata(i)
End If
Next
'strDataSend = strDataSend + vbCrLf
' pos = InStr(1, UCase(strData), "HOST:") + 5
' strHost = getip(Trim(Mid(strData, pos, InStr(pos, strData, vbCrLf) - pos)))
' strHeader = Left(strData, InStr(1, strData, vbCrLf))
'Debug.Print strDataSend
' Debug.Print "========================================"
' Debug.Print strdata
' Debug.Print "========================================"
If strHost = "" Then
wskClent(Index).SendData "HTTP/1.1 400 Bad Request\r\nConnection: close\r\nContent-Type: text/html\r\n\r\n<html><head><title>400 Bad Request</title></head><body><div align=""center""><table border=""0"" cellspacing=""3"" cellpadding=""3"" bgcolor=""#C0C0C0""><tr><td><table border=""0"" width=""500"" cellspacing=""3"" cellpadding=""3""><tr><td bgcolor=""#B2B2B2""><p align=""center""><strong><font size=""2"" face=""Verdana"">400 Bad Request</font></strong></p></td></tr><tr><td bgcolor=""#D1D1D1""><font size=""2"" face=""Verdana""> 主机错误 </font></td></tr></table></center></td></tr></table></div></body></html>"
Exit Sub
End If
wskSend(Index).Close
wskSend(Index).RemoteHost = strHost
wskSend(Index).RemotePort = strPort
'Debug.Print "host:" & strHost
'If InStr(1, strHost, ":") Then
' wskSend(Index).RemoteHost = Left(strHost, InStr(1, strHost, ":") - 1)
' wskSend(Index).RemotePort = Right(strHost, Len(strHost) - InStr(1, strHost, ":"))
' Else
' wskSend(Index).RemoteHost = strHost
' wskSend(Index).RemotePort = 80
' End If
wskSend(Index).Connect '联接主机
'是不是联接成功
Do While wskSend(Index).State <> 7
DoEvents
'Debug.Print Winsock3(Index).State
If wskSend(Index).State = sckError Then
'如果联接错误
wskClent(Index).SendData "HTTP/1.1 400 Bad Request\r\nConnection: close\r\nContent-Type: text/html\r\n\r\n<html><head><title>400 Bad Request</title></head><body><div align=""center""><table border=""0"" cellspacing=""3"" cellpadding=""3"" bgcolor=""#C0C0C0""><tr><td><table border=""0"" width=""500"" cellspacing=""3"" cellpadding=""3""><tr><td bgcolor=""#B2B2B2""><p align=""center""><strong><font size=""2"" face=""Verdana"">400 Bad Request</font></strong></p></td></tr><tr><td bgcolor=""#D1D1D1""><font size=""2"" face=""Verdana""> 不能联接到指定主机 </font></td></tr></table></center></td></tr></table></div></body></html>"
DoEvents
wskClent(Index).Close
wskSend(Index).Close
If Index > 0 Then '从内存中卸载无用的控件
Unload wskClent(Index)
Unload wskSend(Index)
End If
Exit Sub
End If
'Debug.Print "wkssend state:" & wskSend(Index).State
Loop
wskSend(Index).SendData strDataSend
' Debug.Print "========================================"
End Sub
'
'Private Sub wskSend_Close(Index As Integer)
' wskClent(Index).Close
' If Index > 0 Then
' Unload wskClent(Index)
' Unload wskSend(Index)
' End If
'
'End Sub
'
Private Sub wskClent_Close(Index As Integer)
wskSend(Index).Close
If Index > 0 Then
Unload wskClent(Index)
Unload wskSend(Index)
End If
End Sub
'sckClosed 0 关闭状态
'sckOpen 1 打开状态
'sckListening 2 侦听状态
'sckConnectionPending 3 连接挂起
'sckResolvingHost 4 解析域名
'sckHostResolved 5 已识别主机
'sckConnecting 6 正在连接
'sckConnected 7 已连接
'sckClosing 8 同级人员正在关闭连接
'sckError 9 错误
Private Sub wskSend_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim strdata As String
'If bytesTotal = 0 Then
' Exit Sub
'Else
'wskSend(Index).GetData strdata, vbString
' Debug.Print "长度:" & bytesTotal
'End If
'Debug.Print strdata
Dim bty() As Byte
'ReDim bty(1 To bytesTotal) As Byte
If wskSend(Index).State = 7 Then
wskSend(Index).GetData bty, vbByte + vbArray, bytesTotal
End If
'Debug.Print "状态:" & wskClent(Index).State
If wskClent(Index).State = 7 Then
wskClent(Index).SendData bty
'Debug.Print "发回..."
End If
End Sub
Private Sub wskServer_ConnectionRequest(ByVal requestID As Long)
iCount = iCount + 1
Load wskClent(iCount)
Load wskSend(iCount)
wskClent(iCount).Accept requestID
End Sub
网上的代码没一个能正常运行的，根据一些代码，改了一下，基本可以用了！不过，在动态加载winsock的时候，用的一个变量，因为这个变量 一直在增加，所以这里需要改进，靠大家的智慧了！