bfcs.frm

VB 编写 初学者可以拿去做研究 支持源码开发

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
   Caption         =   "BFChat-Server"
   ClientHeight    =   5115
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7245
   LinkTopic       =   "Form1"
   ScaleHeight     =   5115
   ScaleWidth      =   7245
   StartUpPosition =   3  'Windows Default
   Begin VB.Timer wait 
      Enabled         =   0   'False
      Interval        =   2000
      Left            =   4080
      Top             =   2280
   End
   Begin MSWinsockLib.Winsock listen 
      Left            =   4440
      Top             =   2280
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      LocalPort       =   316
   End
   Begin MSWinsockLib.Winsock win 
      Index           =   0
      Left            =   4800
      Top             =   2280
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Frame cons 
      Caption         =   "Console"
      Height          =   1530
      Left            =   75
      TabIndex        =   4
      Top             =   60
      Width           =   7095
      Begin VB.TextBox Console 
         Enabled         =   0   'False
         Height          =   1575
         Left            =   150
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   5
         Top             =   150
         Width           =   6855
      End
   End
   Begin VB.CommandButton say 
      Caption         =   "发送"
      Height          =   315
      Left            =   4680
      TabIndex        =   3
      Top             =   4800
      Width           =   495
   End
   Begin VB.TextBox talk 
      Height          =   1935
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   2760
      Width           =   5055
   End
   Begin VB.TextBox saythat 
      Height          =   285
      Left            =   120
      TabIndex        =   1
      Top             =   4800
      Width           =   4455
   End
   Begin VB.ListBox peoplehere 
      Height          =   2205
      Left            =   5280
      TabIndex        =   0
      Top             =   2880
      Width           =   1935
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False


Private Type chatter  '自定义类型
 Name As String
 IP As String
End Type
Dim noc As Integer
Dim justconnecting As Integer
Dim chatter(5) As chatter  '6个
Dim justtext As String
Dim ws(5)                  'for knowing what Winsocks are free(1=used, 0=free,2 = something else)
Dim jIP As String
Dim jname As String
Dim freews As Integer     '空闲的服务端

Private Sub Console_Change()

 Open "c:\bfc_server_console.log" For Output As #1
  Print #1, Console.Text
 Close #1

End Sub

Private Sub Form_Load()
wait.Enabled = False
listen.listen   '监听
For i = 1 To 5
Load win(i)
Next i
noc = 0
End Sub

'QueryUnload在一个窗体或应用程序关闭之前发生
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 If noc = 0 Then Exit Sub
 For i = 0 To 5
   If ws(i) = 1 Then
    If win(i).State = sckConnected Then
    ws(i) = 2  'for sendcomplete()
    win(i).SendData "Server shutdown!"
    DoEvents
    End If
   End If
 Next i
End Sub



Private Sub listen_ConnectionRequest(ByVal requestID As Long)
 listen.Close
 listen.Accept requestID
End Sub

Private Sub listen_DataArrival(ByVal bytesTotal As Long)
 listen.GetData dat$
 listen.Close        'done? then close and
 listen.listen       'listen again
 Open "c:\um.tmp" For Output As #1  'not the best, but the easiest way(i was just too lazy to do an better one)
  Print #1, dat$
 Close #1
 Open "c:\um.tmp" For Input As #1
  Input #1, IP$
  Input #1, nam
 Close #1
 If nam = "" Then Exit Sub
 For i = 0 To 5
  If nam = chatter(i).Name Then Exit Sub
 Next i
 If noc = 6 Then GoTo errTOOmanySOCKS 'if you changed the number of chatters, please set this to # of chatters + 1
 For i = 0 To 5
  If ws(i) = 0 Then
  freews = i
  GoTo gogo
  End If
 Next i
 GoTo errTOOmanySOCKS
gogo:
 On Error GoTo errIP
 wait.Enabled = True
 jIP = IP
 jname = nam
 Exit Sub
 
errTOOmanySOCKS:
 Console.Text = "->ERROR: SERVER IS FULL!!!" + vbNewLine + Console.Text
Exit Sub
errIP:
 Console.Text = "The Client " + nam + ", " + IP + " has an bad IP or isn't listening" + vbNewLine + Console.Text
End Sub



Private Sub say_Click()
If saythat.Text = "" Then Exit Sub
  justtext = "@SERVER: " + saythat.Text + vbNewLine + talk.Text  'add it to talk
  talk.Text = "@SERVER: " + saythat.Text + vbNewLine + talk.Text
  For i = 0 To 5
  If ws(i) <> 1 Then GoTo gogogo
   win(i).SendData "@SERVER: " + saythat.Text   'distribut the stuff
   DoEvents
gogogo:
  Next i
  saythat.Text = ""
End Sub

 '显示消息

Private Sub talk_Change()
talk.Text = justtext
End Sub
'ReConnect to client
Private Sub wait_Timer()
win(freews).Connect jIP, 317
ws(freews) = 1
chatter(freews).IP = jIP
chatter(freews).Name = jname
peoplehere.AddItem jname
noc = noc + 1
Console.Text = jname + " - " + jIP + " connected" + vbNewLine + Console.Text
wait.Enabled = False
End Sub

Private Sub win_Close(Index As Integer)
ws(Index) = 0
End Sub

Private Sub win_Connect(Index As Integer)
win(Index).SendData vbNewLine + "Welcome you!!  登陆成功" + vbNewLine
End Sub

Private Sub win_DataArrival(Index As Integer, ByVal bytesTotal As Long)
win(Index).GetData dat$ 'get the stuff and
  If dat$ = "IgogogoNOW!!!" Then
  Call disc(Index)
  Exit Sub
  End If
  justtext = chatter(Index).Name + ": " + dat$ + vbNewLine + talk.Text 'add it to talk
  talk.Text = chatter(Index).Name + ": " + dat$ + vbNewLine + talk.Text
  For i = 0 To 5
  If ws(i) <> 1 Then GoTo gogogo
  On Error GoTo err
   win(i).SendData chatter(Index).Name + ": " + dat$  'distribut the stuff
   DoEvents
   GoTo gogogo
err:
   Console.Text = "Unexcepted error! Chatter:" + chatter(i).Name + " - " + chatter(i).IP + vbNewLine + Console.Text
   Exit For
gogogo:
  Next i
 Exit Sub
End Sub

Private Sub win_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)
MsgBox CStr(Index) + vbNewLine + CStr(Number) + vbNewLine + Description
ws(Index) = 0
win(Index).Close
End Sub

Private Sub win_SendComplete(Index As Integer)
If ws(Index) = 2 Then
 win(Index).Close
 ws(Index) = 0
 Console.Text = chatter(Index).Name + " - " + chatter(Index).IP + " kicked!" + vbNewLine + Console.Text
 chatter(Index).IP = ""
 chatter(Index).Name = ""
End If
End Sub

Private Sub disc(Index)
win(Index).Close
ws(Index) = 0
Console.Text = chatter(Index).Name + " - " + chatter(Index).IP + " disconnected!" + vbNewLine + Console.Text
chatter(Index).IP = ""
chatter(Index).Name = ""
noc = noc - 1
On Error GoTo n
peoplehere.RemoveItem (Index)
n:
End Sub