最近需要做一个http代理服务器(用vb),没想到遇到了如此多的问题。贴一下代码:
Option ExplicitDim s(255) As String
Dim h(255) As Byte
Dim p(255) As Byte
Dim i As Integer
Dim tmp() As String
Dim cl(255) As Long, clgot(255) As Boolean
Dim sz(10) As ByteFunction Len2(str As String) As Long
    Len2 = LenB(StrConv(str, vbFromUnicode)) - (Len(str) - Len(Replace(str, vbCrLf, ""))) / 2
End FunctionPrivate Sub cmdStart_Click()
  If cmdStart.Caption = "Start" Then
    wsTCP(0).LocalPort = txtPort
    wsTCP(0).Listen
    lblStatus = "Running..."
    cmdStart.Caption = "Stop"
  Else
    cmdStart.Caption = "Start"
    wsTCP(0).Close
    lblStatus = "Stopped"
  End If
End SubPrivate Sub wsProxy_Close(Index As Integer)
  On Error Resume Next
  Unload wsProxy(Index)
  wsTCP(Index).SendData p(Index)
End SubPrivate Sub wsProxy_Connect(Index As Integer)
  wsProxy(Index).SendData s(Index)
End SubPrivate Sub wsProxy_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
  wsProxy(Index).GetData h(Index)
  p(Index) = p(Index) & h(Index)
  If Replace(p(Index), "Content-Length: ", "") <> p(Index) Then
    tmp() = Split(p(Index), "Content-Length: ")
    tmp() = Split(tmp(1), vbCrLf)
    cl(Index) = Val(tmp(0))
    clgot(Index) = True
  End If
  If Replace(p(Index), vbCrLf + vbCrLf, "") <> p(Index) Then
    tmp() = Split(p(Index), vbCrLf + vbCrLf)
    If Len2(tmp(1)) >= cl(Index) And clgot(Index) = True Then
        cl(Index) = 0
        clgot(Index) = False
        wsTCP(Index).SendData p(Index)
        wsProxy(Index).Close
    End If
  End If
End SubPrivate Sub wsProxy_Error(Index As Integer, 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)
  'Debug.Print "(" & Index & ") Error " & Number & ": " & Description
  If Index <> 0 Then Unload wsProxy(Index)
End SubPrivate Sub wsTCP_Close(Index As Integer)
  Unload wsTCP(Index)
End SubPrivate Sub wsTCP_ConnectionRequest(Index As Integer, ByVal requestID As Long)
  i = i + 1
  Load wsTCP(i)
  Load wsProxy(i)
  wsTCP(i).Accept requestID
End SubPrivate Sub wsTCP_DataArrival(Index As Integer, ByVal bytesTotal As Long)
  wsTCP(Index).GetData s(Index)
  'Debug.Print "(" & Index & ") " & s(Index)
  Dim strHost As String, iPort As Integer
  iPort = 80
  If InStr(UCase(s(Index)), "GET ") > 0 Then
    strHost = Mid(s(Index), InStr(UCase(s(Index)), "GET ") + 4)
  ElseIf InStr(UCase(s(Index)), "PUT ") > 0 Then
    strHost = Mid(s(Index), InStr(UCase(s(Index)), "PUT ") + 4)
  Else
    wsTCP(Index).SendData "Mailformed HTTP request"
    Exit Sub
  End If
  strHost = Left(strHost, InStr(strHost, " ") - 1)
  If InStr(strHost, "://") <> 0 Then strHost = Mid(strHost, InStr(strHost, "://") + 3)
  If InStr(strHost, ":") <> 0 Then
    iPort = Val(Mid(strHost, InStr(strHost, ":") + 1))
    strHost = Left(strHost, InStr(strHost, ":") - 1)
  End If
  If InStr(strHost, "/") > 0 Then strHost = Left(strHost, InStr(strHost, "/") - 1)
  With wsProxy(Index)
    .RemoteHost = strHost
    .RemotePort = iPort
    .Connect
  End With
End SubPrivate Sub wsTCP_Error(Index As Integer, 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)
  'Debug.Print "(" & Index & ") Error " & Number & ": " & Description
  If Index <> 0 Then Unload wsTCP(Index)
End SubPrivate Sub wsTCP_SendComplete(Index As Integer)
  wsTCP(Index).Close
End Sub
有啥控件看代码就可以知道了。
不过有点问题:
1、打开百度首页,偶尔才能打开;打开了也没图片可以看。
2、google根本打不开。
3、404提示页面打开倒是蛮快的。(就是纯文本很快)
4、打开搜狐网就提示我vb遇到问题须退出。
郁闷中,在线等,先谢了各位!

解决方案 »

  1.   

    PS:刚才发布的代码稍加改动,目前问题已基本解决,不过还有:
    请问怎样用其传输二进制网页?目前传输有个问题,就是程序无法准确计算已经得到的二进制数据的字节数。这是为什么图片无法显示的原因~~~百度、Google、搜狐等的网站都以用Gzip进行了压缩,所以应该是二进制数据。另外请问:用String类型存放,会不会影响二进制数据?