最近需要做一个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遇到问题须退出。
郁闷中,在线等,先谢了各位!
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遇到问题须退出。
郁闷中,在线等,先谢了各位!
请问怎样用其传输二进制网页?目前传输有个问题,就是程序无法准确计算已经得到的二进制数据的字节数。这是为什么图片无法显示的原因~~~百度、Google、搜狐等的网站都以用Gzip进行了压缩,所以应该是二进制数据。另外请问:用String类型存放,会不会影响二进制数据?