VB6 制作 HTTP代理服务器

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