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的時候，用的一個變量，因為這個變量 一直在增加，所以這里需要改進，靠大家的智慧了！