frmmain.frm

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

        Next i
    End With
End Sub

Private Sub flxStatistic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton And Shift = vbCtrlMask Then
        PopupMenu mnuStat, , X + 250, Y + 1100
    End If
End Sub

Private Sub Form_Load()
    '窗体启动时
    If App.PrevInstance Then
        '有另一个相同程序正在运行
        End
    End If
    
    LocalIP = sckServer(0).LocalIP
    LoadUser UserList, "UserList.txt"
    LoadUser InvalidList, "Invalid.txt"
    InitializeGrid
    
    Set netProxy = New CProxy
    
    If Len(App.Path & "\" & ConfigFileName) = 0 Then LocalComputerName = sckServer(0).LocalHostName
    '获取初始设置
    LoadProxyConfiguration
    'Winsock集合
    Set ServerConnection = New Collection
    Set ClientConnection = New Collection
    '任务栏图标功能
    Set objSystray = New clsSysTray
    Set objSystray.SourceWindow = Me
    objSystray.ChangeIcon Me.Icon
    objSystray.ToolTip = "Proxy Server Off"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If cmdSwitch.Caption <> "Start" Then
        objSystray.ToolTip = "Personal Proxy Server Off"
        StopProxy
        cmdSwitch.Caption = "Start"
    End If
End Sub

Private Sub Form_Resize()
    tabProxy.Width = Me.ScaleWidth
    If Me.ScaleHeight > (cmdSwitch.Height) Then
        tabProxy.Height = Me.ScaleHeight - (cmdSwitch.Height)
    End If
    If tabProxy.Width > 200 Then
        fraLog.Width = tabProxy.Width - 200
        fraStat.Width = tabProxy.Width - 200
    End If
    If tabProxy.Height > 500 Then
        fraLog.Height = tabProxy.Height - 500
        fraStat.Height = tabProxy.Height - 500
    End If
    If fraLog.Width > 200 Then
        lstLog.Width = fraLog.Width - 200
        flxStatistic.Width = fraStat.Width - 200
    End If
    If fraLog.Height > 240 Then
        lstLog.Height = fraLog.Height - 240
    End If
    If fraStat.Height > 320 Then
        flxStatistic.Height = fraStat.Height - 320
    End If
    fraRequest.Width = fraLog.Width
    fraRequest.Height = fraLog.Height \ 2
    If fraRequest.Height > 400 Then
        txtRequest.Height = fraRequest.Height - 400
    End If
    If fraRequest.Width > 300 Then
        txtRequest.Width = fraRequest.Width - 300
    End If
    fraResponse.Top = fraRequest.Top + fraRequest.Height
    fraResponse.Width = fraLog.Width
    fraResponse.Height = fraLog.Height \ 2
    If fraResponse.Height > 400 Then
        txtResponse.Height = fraResponse.Height - 400
    End If
    If fraResponse.Width > 300 Then
        txtResponse.Width = fraResponse.Width - 300
    End If
    
    With flxStatistic
        .ColWidth(0) = Abs(360 / 6165 * (.Width - 100))
        .ColWidth(1) = Abs(960 / 6165 * (.Width - 100))
        .ColWidth(2) = Abs(2010 / 6165 * (.Width - 100))
        .ColWidth(3) = Abs(915 / 6165 * (.Width - 100))
        .ColWidth(4) = Abs(960 / 6165 * (.Width - 100))
        .ColWidth(5) = Abs(960 / 6165 * (.Width - 100))
        
    End With

    If Me.WindowState = vbMinimized Then
        If cmdSwitch.Caption = "Stop" Then
            objSystray.ChangeIcon Me.Icon
        Else
            objSystray.ChangeIcon frmUserLogin.Icon
        End If
        objSystray.MinToSysTray
    End If
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    '退出窗体时清理变量和Winsock
    Dim Socket As Winsock

    On Error Resume Next
    For Each Socket In sckClient
        CloseSocket Socket.Index
        If Socket.Index <> 0 Then
            Unload Socket
        End If
    Next
    
    For Each Socket In sckServer
        CloseSocket Socket.Index
        If Socket.Index <> 0 Then
            Unload Socket
        End If
    Next
        
    Set netProxy = Nothing
    Set ServerConnection = Nothing
    Set ClientConnection = Nothing

    objSystray.RemoveFromSysTray
    
    Set objSystray = Nothing
End Sub

Private Sub lstLog_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then
        PopupMenu mnuLog, vbPopupMenuRightButton, X + 240, Y + 1060
    End If
End Sub

Private Sub mnuClearHeader_Click()
    txtRequest.Text = ""
    txtResponse.Text = ""
End Sub

Private Sub mnuClearLog_Click()
    lstLog.Clear
End Sub

Private Sub mnuSave_Click()
    SaveUser InvalidList, "Invalid.txt"
End Sub

Private Sub sckClient_Close(Index As Integer)
    InitializeSocket sckClient(Index)

End Sub

Private Sub sckClient_Connect(Index As Integer)
    '连接到外网主机上,开始发送数据
    Dim vData As String
    Static Blocking As Boolean

    '若连接上，则发送数据
    If sckClient(Index).State = sckConnected Then
        vData = ClientConnection(Index).SendBuffer
        If Len(vData) <> 0 And Not Blocking Then
            'Blocking = True
            vData = ClientConnection(Index).SendBuffer.GetString
            SendDataTo sckClient(Index), vData
            'DoEvents
            SendMessage "Connected to Server " & sckClient(Index).RemoteHostIP & ":" & sckClient(Index).RemotePort
            If DEBUG_MODE Then Debug.Print "send to server " & vbCrLf & vData
        End If
    End If
End Sub

Private Sub sckClient_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    '外网主机响应请求，返回数据
    Dim vData As String
    Dim lpos As Long
    Dim Header As String, Data As String

    If Index <> 0 And sckClient(Index).State = sckConnected Then
        
        SendMessage "Receive data from server " & _
                sckClient(Index).RemoteHostIP & ":" & _
                sckClient(Index).RemotePort & " size: " _
                & bytesTotal & " bytes"
        '从外网主机返回数据
        sckClient(Index).GetData vData
        '向内网客户端发送数据
        ServerConnection(Index).Append vData
        AppendLog Index, "From Server " & Index & " :" & vbCrLf & vData
        
        If ServerConnection(Index).HeaderReceived And _
                Not ServerConnection(Index).Connected Then
            If DEBUG_MODE Then Debug.Print "received from server " _
                    & vbCrLf & ServerConnection(Index).Header
            Header = FilterResponseHeader(ServerConnection(Index).Header)
            '数据准备
            ServerConnection(Index).SendBuffer = Header & _
                    vbCrLf & ServerConnection(Index).Data
            ServerConnection(Index).DataSent = _
                    ServerConnection(Index).DataSent + _
                    Len(ServerConnection(Index).Data)
            ServerConnection(Index).Connected = True
            SendResponseHeader "Socket " & Index _
                    & " :" & vbCrLf & Header
            If DEBUG_MODE Then Debug.Print "send to client buffer " _
                    & vbCrLf & Header
        End If
    End If
End Sub

Private Sub sckClient_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)
    '客户端接受数据错误
    '初始化Winsock
    InitializeSocket sckClient(Index)
    ClientConnection(Index).ClearBuffer
    If Index <> 0 Then
        Do While Len(ServerConnection(Index).SendBuffer) <> 0 Or _
                sckServer(Index).State = sckClosed
            DoEvents
        Loop
        InitializeSocket sckServer(Index)
        '清除缓冲
        ServerConnection(Index).ClearBuffer
    End If
End Sub

Private Sub sckServer_Close(Index As Integer)
    '关闭Socket
    CloseSocket Index
End Sub

Private Sub sckServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    '接受到内网客户端请求
    Dim i As Long, ActiveConnection As Long, ReceivingSocket As Winsock
    If Index = 0 Then
        ActiveConnection = 0
        For i = 0 To sckServer.Count - 1
            If i <> 0 Then
                If sckServer(i).State <> sckClosed Then
                    '活动连接数
                    ActiveConnection = ActiveConnection + 1
                End If
        Next i
        获取可用的Socket
        Set ReceivingSocket = AvailableSocket
        '接受连接
        ReceivingSocket.Accept requestID
        If ActiveConnection < MaximumConnection Then
            '接受连接
            SendMessage "Accept connection request from client " & _
                    AvailableSocket.RemoteHostIP & ":" & _
                    ReceivingSocket.RemotePort
        Else
            '连接已到达最大数，拒绝
            ServerConnection(ReceivingSocket.Index).Rejected = True
            SendMessage "Maximum connection reached, " & _
                    "Connection request from client " & _
                    ReceivingSocket.RemoteHostIP & ":" & _
                    ReceivingSocket.RemotePort & " rejected"
        End If
    End If
    
    Set ReceivingSocket = Nothing
End Sub

Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    '内网客户端请求的数据到达代理服务器
    Dim i As Long, lpos As Long
    Dim vData As String
    Static Blocking As Boolean
    Dim Header As String

    If Index <> 0 And sckServer(Index).State = sckConnected Then
        sckServer(Index).GetData vData
        SendMessage "Receive data from client " & _
                    sckServer(Index).RemoteHostIP & ":" & _
                    sckServer(Index).RemotePort & _
                    " size: " & bytesTotal & " bytes"
        ClientConnection(Index).Append vData
        AppendLog Index, "From Client " & Index & " :" & vbCrLf & vData
        AddStatReceived sckServer(Index), Len(vData)
        '当代理服务器获取外网的头信息后
        If ClientConnection(Index).HeaderReceived And Not _
                ClientConnection(Index).Connected Then
            If DEBUG_MODE Then Debug.Print "received from client " & _
                    vbCrLf & ClientConnection(Index).Header
            If ServerConnection(Index).Rejected Then
                '连接被拒绝
                Header = GenerateHTMLForm(ftMaxReached)
                ServerConnection(Index).SendBuffer = Header
                SendResponseHeader "Socket " & Index & " :" & vbCrLf & Header
                DoEvents
                CloseSocket Index
                If DEBUG_MODE Then Debug.Print "send to client buffer " _
                        & vbCrLf & Header
            ElseIf Not ServerConnection(Index).AuthorizeUser Then
                '无用户信息，重新验证
                ServerConnection(Index).AuthorizeUser = _
                        CheckCredential(sckServer(Index), _
                        ClientConnection(Index).Header)
                If Not ServerConnection(Index).AuthorizeUser Then
                    '用户信息验证未通过，则拒绝连接
                    Header = GenerateHTMLForm(ftAuthenticate)
                    ServerConnection(Index).SendBuffer = Header
                    SendResponseHeader "Socket " & Index & " :" & _
                            vbCrLf & Header
                    If DEBUG_MODE Then
                        Debug.Print "send to client buffer " & vbCrLf & Header
                    End If
                Else
                    '初始化到内网客户端的连接
                    InitializeSocket sckClient(Index)
                    Header = FilterRequestHeader(ClientConnection(Index).Header)
                    '代理服务器准备发送数据