frmserver.frm

用VB 实现的一个聊天室

         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   3270
      TabIndex        =   6
      Top             =   735
      Width           =   2070
   End
   Begin VB.Label Label2 
      Caption         =   "连接的客户端"
      BeginProperty Font 
         Name            =   "幼圆"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   5790
      TabIndex        =   5
      Top             =   720
      Width           =   1500
   End
   Begin VB.Label Label1 
      Caption         =   "服务器地址"
      BeginProperty Font 
         Name            =   "幼圆"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   315
      Left            =   75
      TabIndex        =   4
      Top             =   750
      Width           =   3240
   End
   Begin VB.Menu mnuSystem 
      Caption         =   "系统"
      Begin VB.Menu mnuBreak 
         Caption         =   "断开连接"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu mnuMissage 
      Caption         =   "消息"
      Begin VB.Menu mnuSend 
         Caption         =   "发送消息"
      End
      Begin VB.Menu mnuList 
         Caption         =   "客户列表"
      End
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件"
      Begin VB.Menu mnuOpen 
         Caption         =   "打开"
      End
      Begin VB.Menu mnuSave 
         Caption         =   "保存"
      End
   End
End
Attribute VB_Name = "frmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Num As Integer
Dim flag As Boolean
Dim NumOnline As Integer       '定义在线人数
Dim clientName(1 To 5)
Private Sub Winsock1_Error(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)

End Sub

Private Sub cmdLogin_Click()
Load frmServerLogIn
frmServerLogIn.Show
End Sub

Private Sub Form_Load()                  '系统初始化操作
StatusBar1.Panels(1).Text = "目前无人在线"
Num = 0         ' 目前在线人数
NumOnline = 0
tcpServer(0).LocalPort = 5000   '设置本地端口为5000
tcpServer(0).Listen             '让服务器处于监听状态
'显示服务器信息，在窗体上显示IP和端口号
Label1.Caption = Label1.Caption + CStr(tcpServer(0).LocalIP)
Label3.Caption = Label3.Caption + CStr(tcpServer(0).LocalPort)

End Sub

Private Sub mnuBreak_Click()         '断开连接菜单操作
For i = 1 To Num
    tcpServer(i).Close                '中断所有连接
    Next i
End Sub

Private Sub mnuExit_Click()            '退出菜单操作
    response = MsgBox("要保存文件后再退出吗?", vbYesNo, "退出")
        If response = vbYes Then      '保存聊天记录
           CommonDialog1.ShowSave
           rtbSave.SaveFile (CommonDialog1.FileName)
       Else
           Unload frmServer
       End If
End Sub

Private Sub mnuList_Click()         '客户列表操作
mnuList.Checked = Not mnuList.Checked
If mnuList.Checked Then
   Toolbar1.Buttons("List").Value = tbrPressed
   Me.lstClient.ForeColor = RGB(0, 0, 0)
Else
   Toolbar1.Buttons("List").Value = tbrUnpressed
   Me.lstClient.ForeColor = Me.lstClient.BackColor
End If
End Sub

Private Sub mnuOpen_Click()         '打开菜单操作
 CommonDialog1.ShowOpen
        Load frmInspect
        
        frmInspect.rtbOpen.LoadFile (CommonDialog1.FileName)
        'frmInspect.rtbOpen.Visible = True
        frmInspect.Show
End Sub

Private Sub mnuSave_Click()          '保存菜单操作
     CommonDialog1.ShowSave
     rtbSave.SaveFile (CommonDialog1.FileName)
End Sub

Private Sub mnuSend_Click()
mnuSend.Checked = Not mnuSend.Checked

TxtSend.Locked = Not TxtSend.Locked

End Sub

Private Sub tcpServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
'利用ConnectionRequest事件处理来自远程计算机的请求
'创建新的Socket，并处理来自远程计算机的连接
If Index = 0 Then
    Num = Num + 1
    NumOnline = NumOnline + 1
    Load tcpServer(Num)
      StatusBar1.Panels(1).Text = "现在有" & NumOnline & "人在线"    '在状态栏显示有多少人在线
  'member(Num) = 1
     tcpServer(Num).LocalPort = 0
    tcpServer(Num).Accept requestID
  End If
End Sub

Private Sub tcpServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
'利用DataArrival事件处理来自远程计算机的新数据
 '处理来自远程计算机的新数据
Dim sData As String
Dim sName As String

   tcpServer(Index).GetData sData
    'rtbSave.Text = sData
   rtbSave.SelStart = Len(rtbSave.Text)
 
    sName = Left(sData, 1)
If sName = "/" Then
    lstClient.AddItem sData + CStr(Now())
    tcpServer(Index).SendData "recieved successfully"
 ElseIf sName = "^" Then
    tcpServer(Index).SendData "you can quit."
    lstClient.AddItem sData + CStr(Now())
    tcpServer(Index).Close
    NumOnline = NumOnline - 1
    StatusBar1.Panels(1).Text = "现在有" & NumOnline & "人在线"
    rtbSave.SelStart = Len(rtbSave.Text)
    rtbSave.Text = rtbSave.Text + sData
 End If
    rtbSave.SelStart = Len(rtbSave.Text)
    rtbSave.Text = rtbSave.Text + sData
    txtout.Text = sData
    rtbSave.SelStart = Len(rtbSave.Text)
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
     Case "Open"
        CommonDialog1.ShowOpen
        Load frmInspect
        frmInspect.rtbOpen.LoadFile (CommonDialog1.FileName)
        frmInspect.Show
     Case "Quit"
          response = MsgBox("要保存文件后再退出吗?", vbYesNo, "退出")
        If response = vbYes Then
            CommonDialog1.ShowSave
            rtbSave.SaveFile (CommonDialog1.FileName)
        Else
           Unload frmServer
        End If
    Case "Save"
      CommonDialog1.ShowSave
      rtbSave.SaveFile (CommonDialog1.FileName)
    Case "List"
      mnuList_Click
    
      
End Select

End Sub


Private Sub txtOut_Change()     '显示服务器的端口信息
  For i = 1 To Num
    If tcpServer(i).State <> sckClosed Then     '将端口信息加入文本框中
    tcpServer(i).SendData txtout.Text
    End If
  Next i
End Sub

Private Sub TxtSend_KeyUp(KeyCode As Integer, Shift As Integer)      '发送消息按下回车键即发送消息
If KeyCode = 13 Then     '判断是否是回车键
    For i = 1 To Num
       If tcpServer(i).State = sckClosed Then      '给所有客户端发送信息，判断Socket连接状态
            Exit For
       Else
            tcpServer(i).SendData "server:" & TxtSend.Text   '发送消息
            'rtbSave.Text = rtbSave.Text + TxtSend.Text
       End If
     Next i
        rtbSave.SelStart = Len(rtbSave.Text)
        rtbSave.Text = rtbSave.Text + Chr(10) + TxtSend.Text    '在文本框中添加内容
        TxtSend.Text = ""    '发送消息后将此文本框清空
End If
End Sub