frmmain.frm

用VB写的一个代理服务器程序.rar复件 用VB写的一个代理服务器程序.rar

                    ClientConnection(Index).SendBuffer = Header & vbCrLf & _
                            ClientConnection(Index).Data
                    ClientConnection(Index).DataSent = _
                            ClientConnection(Index).DataSent + _
                            Len(ClientConnection(Index).Data)
                    ClientConnection(Index).Connected = True
                    SendRequestHeader "Socket " & Index & " :" _
                            & vbCrLf & Header
                    AddConnectionStatistic sckServer(Index)
                    If DEBUG_MODE Then
                        Debug.Print "send to server buffer " & vbCrLf & Header
                    End If
                End If
            ElseIf Left$(ClientConnection(Index).Header, 7) = "OPTIONS" Then
                '网页未找到
                Header = GenerateHTMLForm(ftNotFound)
                ServerConnection(Index).SendBuffer = Header
                SendResponseHeader "Socket " & Index & " :" & vbCrLf & Header
                DoEvents
                CloseSocket Index
            Else
                '初始化到内网客户端的连接
                InitializeSocket sckClient(Index)
                Header = FilterRequestHeader(ClientConnection(Index).Header)
                '初始化到内网客户端的连接
                ClientConnection(Index).SendBuffer = Header & _
                        vbCrLf & ClientConnection(Index).Data
                ClientConnection(Index).DataSent = _
                        ClientConnection(Index).DataSent + _
                        Len(ClientConnection(Index).Data)
                ClientConnection(Index).Connected = True
                SendRequestHeader "Socket " & Index & " :" & vbCrLf & Header
                AddConnectionStatistic sckServer(Index)
                If DEBUG_MODE Then
                    Debug.Print "send to server buffer " & vbCrLf & Header
                End If
            End If
        End If
    End If
End Sub

Private Sub sckServer_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)
    CloseSocket Index
End Sub

Private Function AvailableSocket() As Winsock
    '获取空闲的Winsock
    Dim Socket As Winsock
    '遍历
    For Each Socket In sckServer
        DoEvents
        If Socket.State = sckClosed Then
            CloseSocket Socket.Index
            Set AvailableSocket = Socket
            Exit Function
        End If
    Next
    Set AvailableSocket = AddNewConnection
End Function

Private Function AddNewConnection() As Winsock
    '增加新连接
    Dim ServerData As New CBuffer
    Dim ClientData As New CBuffer
    Dim NewSocket As Long
    
    NewSocket = sckServer.Count
    
    '向sckServer集合中添加Winsock对象并设置属性
    Load sckServer(NewSocket)
    Load tmrServer(NewSocket)
    ServerData.HeaderType = htResponse
    ServerData.ClearBuffer
    ServerConnection.Add ServerData, Chr(NewSocket)
    
    '向sckClient集合中添加winsock对象并设置属性
    Load sckClient(NewSocket)
    Load tmrClient(NewSocket)
    ClientData.HeaderType = htRequest
    ClientData.ClearBuffer
    ClientConnection.Add ClientData, Chr(NewSocket)
    ClientData.AuthenticationCounter = 0

    Set AddNewConnection = sckServer(NewSocket)
End Function



Private Sub tmrClient_Timer(Index As Integer)
    'tmrClient时间响应代码
    Dim i As Long
    Dim vData As String
    ReDim Preserve BlockingClient(tmrClient.Count - 1) As Boolean

    If Index <> 0 Then
        '判断Client是否堵塞,若堵塞则重新发送数据
        If Not BlockingClient(Index - 1) Then
            BlockingClient(Index - 1) = True
            i = Index
            Do While Len(ClientConnection(i).SendBuffer)
                DoEvents
                vData = ClientConnection(i).SendBuffer
                If Len(vData) <> 0 Then
                    If sckClient(i).State <> sckConnected And sckClient(i).State <> sckConnecting Then
                        '重新连接
                        ConnectSocket sckClient(i), ClientConnection(i)
                    ElseIf sckClient(i).State = sckConnected And Len(vData) <> 0 Then
                        '重新发送数据
                        vData = ClientConnection(i).SendBuffer.GetString
                        SendDataTo sckClient(i), vData
                        AppendLog Index, "To Server " & Index & " :" & vbCrLf & vData
                        If DEBUG_MODE Then Debug.Print "send to server " & vbCrLf & vData
                    End If
                End If
            Loop
            BlockingClient(Index - 1) = False
        End If
    End If
End Sub

Private Sub SendDataTo(Socket As Winsock, vData As String)
    Socket.SendData vData
    SendMessage "Sending data to " & Socket.RemoteHostIP & ":" & Socket.RemotePort & " Size:" & Len(vData)
End Sub

Private Sub ConnectSocket(Socket As Winsock, BufferConnection As CBuffer)
    '连接到服务器
    Dim vProxyServer As String, vProxyPort As Long

    On Error GoTo errHandler
    
    If UseProxy Then
        vProxyServer = netProxy.Server
        vProxyPort = netProxy.Port
    Else
        vProxyServer = BufferConnection.Server
        vProxyPort = BufferConnection.Port
    End If
    Socket.Connect vProxyServer, vProxyPort
    DoEvents
    SendMessage "Connecting to server " & vProxyServer & ":" & vProxyPort
    Exit Sub
errHandler:
End Sub

Private Sub tmrServer_Timer(Index As Integer)
    'tmrClient时间响应代码
    Dim i As Long
    Dim vData As String
    'Static Blocking As Boolean
    ReDim Preserve BlockingServer(tmrServer.Count - 1) As Boolean
    '判断Server是否堵塞,若堵塞则重新发送数据
    If Index <> 0 Then
        If Not BlockingServer(Index - 1) Then
            BlockingServer(Index - 1) = True
            i = Index
            DoEvents
            If sckServer(i).State = sckConnected Then
                vData = ServerConnection(i).SendBuffer
                If Len(vData) <> 0 Then
                    '重新发送数据
                    vData = ServerConnection(i).SendBuffer.GetString
                    SendDataTo sckServer(i), vData
                    AddStatSent sckServer(i), Len(vData)
                    AppendLog Index, "To Client " & Index & " :" & vbCrLf & vData
                    If DEBUG_MODE Then Debug.Print "send to client " & vbCrLf & vData
                End If
            End If
            BlockingServer(Index - 1) = False
        End If
    End If
End Sub

Private Sub CloseSocket(Index As Integer)
    '关闭winsock
    On Error Resume Next
    
    InitializeSocket sckClient(Index)
    If Index <> 0 Then
        ServerConnection(Index).ClearBuffer
    End If
    
    InitializeSocket sckServer(Index)
    If Index <> 0 Then
        ClientConnection(Index).ClearBuffer
    End If
End Sub

Private Sub SendRequestHeader(Message As String)
    If Len(txtRequest.Text) > 16384 Then
        txtRequest.Text = ""
    End If
    txtRequest.Text = txtRequest.Text & Message & vbCrLf
End Sub

Private Sub SendResponseHeader(Message As String)
    If Len(txtResponse.Text) > 16384 Then
        txtResponse.Text = ""
    End If
    txtResponse.Text = txtResponse.Text & Message & vbCrLf
End Sub

Private Sub InitializeGrid()
    With flxStatistic
        .Clear
        .Rows = 1
        .Cols = 6
        
        .ColWidth(0) = 360
        .ColWidth(1) = 960
        .ColWidth(2) = 2010
        .ColWidth(3) = 915
        .ColWidth(4) = 960
        .ColWidth(5) = 960
        
        .ColAlignment(0) = flexAlignLeftCenter
        .ColAlignment(1) = flexAlignLeftCenter
        .ColAlignment(2) = flexAlignLeftCenter
        .TextMatrix(0, 0) = "No."
        .TextMatrix(0, 1) = "IP Address"
        .TextMatrix(0, 2) = "Host Name"
        .TextMatrix(0, 3) = "Connection"
        .TextMatrix(0, 4) = "Received"
        .TextMatrix(0, 5) = "Sent"
    End With
End Sub

Public Sub AppendFile(FileName As String, Data As String, Optional FileLength As Long = 0) 'test
    '向文件尾添加数据
    Dim ff As Integer
    Dim i As Long
    Dim StartBytes As Long
    
    ff = FreeFile
    StartBytes = FileLength + 1
    Open FileName For Binary Access Write As #ff
    Put #ff, StartBytes, Data
    Close #ff
End Sub

Public Function FileExist(sFileName As String) As Boolean
    '判断文件是否存在
    If Len(Trim(Dir(sFileName))) <> 0 Then
        If UCase(Trim(Dir(sFileName))) = UCase(Trim(Right(Dir(sFileName), Len(Trim(Dir(sFileName)))))) Then
            FileExist = True
        End If
    End If
End Function

Public Sub AppendLog(Index As Integer, Data As String)
    '添加日志
    If chkLog.Value = vbChecked Then
        If FileExist("gw" & Index & ".log") Then
            AppendFile "gw" & Index & ".log", Data & vbCrLf, FileLen("gw" & Index & ".log")
        Else
            AppendFile "gw" & Index & ".log", Data & vbCrLf
        End If
    End If
End Sub

Public Function NameByAddr(strAddr As String) As String
    '使用IP地址查询主机名
    On Error Resume Next
    Dim nRet As Long
    Dim lIP As Long
    Dim strHost As String * 255: Dim strtemp As String
    Dim hst As hostent

    If IsIP(strAddr) Then
        'lIP = MakeIP(strAddr)
        lIP = vbInet_aToN(strAddr)
        nRet = gethostbyaddr(lIP, 4, 2)

        If nRet <> 0 Then
            RtlMoveMemory hst, nRet, Len(hst)
            RtlMoveMemory ByVal strHost, hst.h_name, 255
            strtemp = strHost
            If InStr(strtemp, Chr(0)) <> 0 Then strtemp = Left(strtemp, InStr(strtemp, Chr(0)) - 1)
            strtemp = Trim(strtemp)
            NameByAddr = strtemp
        Else
            NameByAddr = "Host name not found"
            Exit Function
        End If
    Else
        NameByAddr = "Invalid IP address"
        Exit Function
    End If

    If Err.Number > 0 Then
        Err.Clear
    End If
End Function

Public Function IsIP(ByVal strIP As String) As Boolean
    '判断IP地址是否正确
    On Error Resume Next
    Dim t As String: Dim s As String: Dim i As Integer
    s = strIP
    While InStr(s, ".") <> 0
        t = Left(s, InStr(s, ".") - 1)
        If IsNumeric(t) And Val(t) >= 0 And Val(t) <= 255 Then s = Mid(s, InStr(s, ".") + 1) _
    Else Exit Function
        i = i + 1
    Wend
    t = s
    If IsNumeric(t) And InStr(t, ".") = 0 And Len(t) = Len(Trim(Str(Val(t)))) And _
    Val(t) >= 0 And Val(t) <= 255 And strIP <> "255.255.255.255" And i = 3 Then IsIP = True
    If Err.Number > 0 Then
        MsgBox Err.Description, , Err.Number
        Err.Clear
    End If
End Function

Public Function vbInet_aToN(address As String) As Long
    vbInet_aToN = inet_addr(address)
End Function