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的时候，用的一个变量，因为这个变量 一直在增加，所以这里需要改进，靠大家的智慧了！