form1
module1
module 2
how to use it
Code:
Option Explicit
Dim TotalS As Integer
Dim CHdat() As String
Dim SEhead() As String
Dim UN As String
Private Sub Form_Load()
MsgBox "Proxy is listing on port 8080, click OK to continue", vbOKOnly, "__"
TotalS = 0
sin(0).LocalPort = 8080
sin(0).Listen
End Sub
Private Function GetFreeSocket() As String
Dim I As Long
For I = 1 To TotalS
If (sin(I).State = 0) Or (sin(I).State = 9) Or (sin(I).State = 8) Then
sin(I).Close
sout(I).Close
GetFreeSocket = I
Exit Function
End If
Next I
'//no free socks found, create one
TotalS = TotalS + 1
Load sin(TotalS)
Load sout(TotalS)
ReDim Preserve CHdat(TotalS)
ReDim Preserve SEhead(TotalS)
GetFreeSocket = TotalS
End Function
Private Sub sin_Close(Index As Integer)
Dim tTemp As String
tTemp = CHdat(Index)
If tTemp <> vbNullString Then
AnalyzeReceivedData (tTemp)
End If
SEhead(Index) = vbNullString
sin(Index).Close
sout(Index).Close
End Sub
Private Sub sin_ConnectionRequest(Index As Integer, ByVal requestID As Long)
sin(GetFreeSocket).Accept requestID
End Sub
Private Sub sin_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim sDat As String
sin(Index).GetData sDat
SEhead(Index) = sDat
sout(Index).Close
sout(Index).Connect GetHeader(sDat, "host"), 80
End Sub
Private Sub sin_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)
If Index > 0 Then
sin(Index).Close
sout(Index).Close
End If
End Sub
Private Sub sout_Close(Index As Integer)
sin(Index).Close
sout(Index).Close
Dim tTemp As String
tTemp = CHdat(Index)
If tTemp <> vbNullString Then
AnalyzeReceivedData (tTemp)
End If
SEhead(Index) = vbNullString
CHdat(Index) = vbNullString
End Sub
Private Sub sout_Connect(Index As Integer)
sout(Index).SendData SEhead(Index)
SEhead(Index) = vbNullString
End Sub
Private Sub sout_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim sDat As String
Dim Pos1 As Long
sout(Index).GetData sDat
sin(Index).SendData sDat
If InStrB(LCase$(GetHeader(sDat, "transfer-encoding")), "chunked") Then
CHdat(Index) = sDat
Else
If CHdat(Index) <> vbNullString Then
If Len(sDat) = 0 Then MsgBox "end"
CHdat(Index) = CHdat(Index) & sDat
Else
AnalyzeReceivedData (sDat) '// no chunked transferencoding used,
'// Data can be analyzed straight away
End If
End If
End Sub
Private Sub sout_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)
sin(Index).Close
sout(Index).Close
End Sub
Private Sub Timer1_Timer()
Form1.Caption = TotalS
End Sub
Private Sub AnalyzeReceivedData(ByRef sHtml As String)
Clipboard.Clear
Clipboard.SetText sHtml
MsgBox sHtml
End Submodule1
Code:
Option Explicit
Public Sub GetAllTags(sHtml As String, ByRef sArray() As String)
Dim Pos1 As Long
Dim Pos2 As Long
Dim ub As Long
ReDim sArray(0)
Do
Pos1 = InStr(Pos2 + 1, sHtml, "<")
Pos2 = InStr(Pos1 + 1, sHtml, ">")
If (Pos1 < 1) Or (Pos2 < 1) Then Exit Do
ub = UBound(sArray)
sArray(ub) = Mid$(sHtml, Pos1, Pos2 - Pos1 + 1)
ReDim Preserve sArray(ub + 1)
Loop
If ub > 0 Then ReDim Preserve sArray(ub)
End Sub
Public Function GetTagType(Tag As String) As String
Dim Pos As Integer
Pos = InStr(1, Tag, " ")
If Pos < 1 Then Pos = Len(Tag)
GetTagType = LCase$(Mid$(Tag, 2, Pos - 2))
End Function
Public Function GetTagAttrValue(Tag, Attr As String) As String '//<a href=> href is the attr
Dim Pos As Long
Dim Pos2 As Long
Dim Sep As String
Attr = " " & Attr '//An atribute is always prefixed with a space
Pos = InStr(1, LCase$(Tag), LCase$(Attr))
If Pos < 1 Then Exit Function '// ATTR NOT FOUND___
Pos = Pos + Len(Attr) '//Move forward to the end of attr
Do
Sep = Mid$(Tag, Pos, 1)
Pos = Pos + 1
Loop While (Sep = " ") Or (Sep = "=")
Select Case Sep
Case "'"
Pos2 = InStr(Pos + 1, Tag, "'")
GetTagAttrValue = Mid$(Tag, Pos, Pos2 - Pos)
Case Chr(34)
Pos2 = InStr(Pos + 1, Tag, Chr(34))
GetTagAttrValue = Mid$(Tag, Pos, Pos2 - Pos)
Case Else 'sep is " ", or ">"
Pos2 = InStr(Pos + 1, Tag, " ")
If Pos2 < 1 Then Pos2 = Len(Tag) - 1 '//if no space is found, the end='>', thats always on the end so len is faster
GetTagAttrValue = Mid$(Tag, Pos - 1, Pos2 - Pos + 1)
End Select
End Functionmodule 2
Code:
Option Explicit
Public Function GetHeader(ByRef rDat As String, ByRef header As String) As String ', "header"
'//On Error GoTo sEnd:
Dim Pos1 As Integer, Pos2 As Integer
header = header & ": "
Pos1 = InStr(1, LCase$(rDat), header) + Len(header)
If Pos1 = Len(header) Then Exit Function '//no header found
Pos2 = InStr(Pos1, LCase$(rDat), vbCrLf)
If Pos2 = 0 Then Exit Function
GetHeader = Mid(rDat, Pos1, Pos2 - Pos1)
sEnd:
End Function
Public Function GetRequestHost(ByRef ReqHeader As String) As String
Dim Pos1 As Integer
Dim tTemp As String
Pos1 = InStr(ReqHeader, " ") + 1
tTemp = Mid(ReqHeader, Pos1, InStr(Pos1, ReqHeader, " ") - Pos1)
If InStr(LCase$(tTemp), "http://") = 1 Then
tTemp = Mid(tTemp, 8)
End If
Pos1 = InStr(tTemp, "/")
If Pos1 < 1 Then '//no path found,
GetRequestHost = tTemp
Exit Function
Else
GetRequestHost = Mid(tTemp, 1, Pos1 - 1)
Exit Function
End If
End Function
Public Function GetRequestPath(ByRef sHtml As String) As String
Dim Pos1 As Integer
Dim tTemp As String
Pos1 = InStr(sHtml, " ") + 1
tTemp = Mid(sHtml, Pos1, InStr(Pos1, sHtml, " ") - Pos1)
If InStr(LCase$(tTemp), "http://") = 1 Then
tTemp = Mid(tTemp, 8)
End If
Pos1 = InStr(tTemp, "/")
If Pos1 < 1 Then '//no path found,
tTemp = "/"
Exit Function
Else
GetRequestPath = Mid(tTemp, Pos1)
End If
Pos1 = InStr(tTemp, "?")
If Pos1 < 1 Then
Exit Function
Else
GetRequestPath = Mid(tTemp, 1, Pos1 - 1)
Exit Function
End If
End Functionhow to use it