frmmain.frm

完整的主机服务器, (含代码).程序会监视联结到主机程序上的所有机器.可是设置开启端口,最多用户..非常完整.!

         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H0080FF80&
      Height          =   225
      Left            =   150
      TabIndex        =   3
      Top             =   4350
      Width           =   960
   End
End
Attribute VB_Name = "frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub Check1_Click()
    If Check1.Value = vbChecked Then Command4.Enabled = True
    If Check1.Value <> vbChecked Then Command4.Enabled = False
End Sub



Private Sub cmdDirShare_Click()
    frmDirShare.ShowMe
End Sub

Private Sub cmdSvrConf_Click()
    FileCopy "..\conf\http.cfg", "..\conf\http.old"
    frmServerConfig.ShowMe
End Sub

Private Sub cmdUsers_Click()
    frmUsrAdmin.ShowMe
End Sub

Private Sub cmdVDir_Click()
    frmVDirs.ShowMe
End Sub

Private Sub cmdVHost_Click()
    frmVHosts.ShowMe
End Sub

Private Sub Command1_Click()
 StopServer
End Sub

Private Sub Command2_Click()
   StartServer
End Sub

Private Sub Command3_Click()
 Shell "notepad.exe " & ServerLogFile, vbNormalFocus
End Sub

Public Sub Command4_Click()
    Cout "Closing..."
    ' Save The Configuration Files
    CLOSEDOWNSERVER
    
End Sub

Private Sub Form_Load()
   InitServer
   CheckInitUpdate
   WLog "Server Started", 0
   
   Cout "LongBow Server 1.0b" & vbCrLf
   Cout "-------------------" & vbCrLf
   Cout "Listening On Port " & Trim$(Str$(Longbow.ListenPort)) & vbCrLf
   Cout "Server Config Loaded" & vbCrLf
   Cout "LogFile:" & ServerLogFile & vbCrLf
End Sub

Private Sub Form_Unload(Cancel As Integer)
   CloseServer
   End
End Sub

Private Sub sxt_Timer()
   On Error GoTo SXTERR
   Dim t As Integer
   If sxt.Tag = "POTATO" Then Exit Sub
   sxt.Tag = "POTATO"
   Do Until sxt.Enabled = False
    'lblSXT.Caption = lblSXT.Caption + 1
    lblReq.Caption = Trim$(Str$(NumReq))
    
    For t = 1 To Longbow.MaxSocks Step 2
                  DoEvents
                  If sx(t).Header <> "" And sx(t).Reqok = False And sx(t).Buffer = "" And ws(t).State = sckConnected Then
                     ProcessHeader t
                  End If

                     sx(t).TimeAlive = sx(t).TimeAlive + 1
            
                    
                     If sx(t).TimeAlive > (Longbow.TimeOut / 10) Then
                        ws(t).Close
                        sx(t).Buffer = ""
                        sx(t).Header = ""
                        sx(t).Reqok = False
                        sx(t).TimeAlive = 0
                     End If

                  If sx(t).Reqok = True And ws(t).State <> sckConnected Then
                        ws(t).Close
                        sx(t).Buffer = ""
                        sx(t).Header = ""
                        sx(t).Reqok = False
                        sx(t).TimeAlive = 0
                        ws(t).Tag = ""
                  End If

                  If sx(t).Reqok = True And ws(t).State = sckConnected Then
            
                     a = Len(sx(t).Buffer)
            
                     'Debug.Print a
            
                     If a = 0 And frmmain.ws(t).Tag = "LASTPACKET" Then
                        ws(t).Close
            
                        sx(t).Buffer = ""
                        sx(t).Header = ""
                        sx(t).Reqok = False
                        sx(t).TimeAlive = 0
                        ws(t).Tag = ""
                        GoTo RABIDO
                     End If
                     'If a = 0 Then GoTo RABIDO
                     If a > 3000 Then g = 3000 Else g = a: ws(t).Tag = "LASTSEND"
                     r$ = Left$(sx(t).Buffer, g)
                     sx(t).Buffer = Right$(sx(t).Buffer, Len(sx(t).Buffer) - g)

                     ws(t).SendData r$

                     sx(t).TimeAlive = 0
                  End If
RABIDO:
            '         ws(t).SendData sx(t).Buffer
            '         sx(t).Reqok = False
            '         sx(t).Buffer = ""
            
            
                  If sx(t).Reqok = True And ws(t).State <> sckConnected Then
                     ws(t).Close
                     sx(t).Buffer = ""
                     sx(t).Header = ""
                     sx(t).Reqok = False
                     sx(t).TimeAlive = 0
                     ws(t).Tag = ""
                  End If
   Next t
   Loop
   sxt.Tag = ""
   Exit Sub
SXTERR:
   sxt.Tag = ""
   Debug.Print "SXT Error " & Err.Description
End Sub

Private Sub sxu_Timer()
   Dim t As Integer
   For t = 0 To Longbow.MaxSocks Step 2
      'lblSXU.Caption = lblSXU.Caption + 1
      If t <> 0 Then
      
      
      
      DoEvents

      If sx(t).Header <> "" And sx(t).Reqok = False And sx(t).Buffer = "" And ws(t).State = sckConnected Then

         ProcessHeader t
      End If

         sx(t).TimeAlive = sx(t).TimeAlive + 1
      'If ws(t).State = sckConnected Then Debug.Print sx(t).TimeAlive

         If sx(t).TimeAlive > Longbow.TimeOut Then
            ws(t).Close
            sx(t).Buffer = ""
            sx(t).Header = ""
            sx(t).Reqok = False
            sx(t).TimeAlive = 0
         End If

      If sx(t).Reqok = True And ws(t).State <> sckConnected Then
            ws(t).Close
            sx(t).Buffer = ""
            sx(t).Header = ""
            sx(t).Reqok = False
            sx(t).TimeAlive = 0
            ws(t).Tag = ""
      End If

      If sx(t).Reqok = True And ws(t).State = sckConnected Then

         a = Len(sx(t).Buffer)

         'Debug.Print a

         If a = 0 And frmmain.ws(t).Tag = "LASTPACKET" Then
            ws(t).Close

            sx(t).Buffer = ""
            sx(t).Header = ""
            sx(t).Reqok = False
            sx(t).TimeAlive = 0
            ws(t).Tag = ""
            GoTo RABIDO
         End If
         'If a = 0 Then GoTo RABIDO
         If a > 3000 Then g = 3000 Else g = a: ws(t).Tag = "LASTSEND"
         r$ = Left$(sx(t).Buffer, g)
         sx(t).Buffer = Right$(sx(t).Buffer, Len(sx(t).Buffer) - g)

         ws(t).SendData r$

         sx(t).TimeAlive = 0
      End If
RABIDO:
'         ws(t).SendData sx(t).Buffer
'         sx(t).Reqok = False
'         sx(t).Buffer = ""


      If sx(t).Reqok = True And ws(t).State <> sckConnected Then
         ws(t).Close
         sx(t).Buffer = ""
         sx(t).Header = ""
         sx(t).Reqok = False
         sx(t).TimeAlive = 0
         ws(t).Tag = ""
      End If


      End If
      
   Next t
      
End Sub

Private Sub sxz_Timer()
    Dim t, u As Long
    For t = 1 To Longbow.MaxSocks
        If ws(t).State = sckConnected Then u = u + 1
    Next t
    lblConnUsr.Caption = Trim$(Str$(u))
End Sub

Private Sub ws_Close(Index As Integer)
   sx(Index).Buffer = ""
   sx(Index).Header = ""
   sx(Index).Reqok = False
   sx(Index).TimeAlive = 0
   ws(Index).Tag = ""
End Sub

Private Sub ws_ConnectionRequest(Index As Integer, ByVal requestID As Long)
   Dim t As Integer
   For t = 1 To Longbow.MaxSocks
      If ws(t).State = sckClosing Then ws(t).Close
      If ws(t).State = sckClosed Then
         ws(t).Accept requestID
         sx(t).Buffer = ""
         sx(t).Header = ""
         sx(t).Reqok = False
         sx(t).TimeAlive = 0
         ws(t).Tag = ""
         If IPBanned(t) = 1 Then
            WriteHTTP t, 403, "-"
            sx(t).Reqok = True
            sx(t).Header = "HAS BEEN BANNED"
            Exit Sub
         End If
         Exit Sub
      End If
   Next t
End Sub

Private Sub ws_DataArrival(Index As Integer, ByVal bytesTotal As Long)
   On Error GoTo WSDAO
   ws(Index).GetData sx(Index).Header
   'ProcessHeader Index
   Exit Sub
WSDAO:
         ws(Index).Close
         sx(Index).Buffer = ""
         sx(Index).Header = ""
         sx(Index).Reqok = False
         sx(Index).TimeAlive = 0
         ws(Index).Tag = ""
End Sub

Private Sub ws_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)
   ws(Index).Close
   ' If the listening socket closes, we're buggered, so open it up again, probably causing another error
   ' and the program to crash, but hey, windows crashes, so why can't this? :p
   If Index = 0 Then ws(0).Listen
End Sub

Private Sub ws_SendComplete(Index As Integer)
If ws(Index).Tag = "LASTSEND" Then
   ws(Index).Tag = "LASTPACKET"
End If
End Sub