myim.frm

Com串口即时通讯工具.有服务端和客启端..是学习的好程度!

Private Sub mnuFileReport_Click()
    frmReport.Show
End Sub

'==============
'登陆菜单
'==============
Private Sub mnuFileToggleLog_Click()

'如果菜单状态为注销状态，则关闭连接，如果为登陆状态，则显示连接服务器窗体
If mnuFileToggleLog.Caption = "注销(&L)" Then

   mnuFileToggleLog.Caption = "登陆(&L)"
   Winsock1.Close
   BuddyUpdater.Enabled = False
   Command1.Enabled = False
   Command2.Enabled = False
   Label1.Caption = "离线"
   TreeView1.Nodes.Clear
   mnuBuddyMessage.Enabled = False
   mnuStatus.Enabled = False
   mnuBuddyFile.Enabled = False
   mnuBuddyChat.Enabled = False
   mnuBuddyInfo.Enabled = False
   mnuFileChangeInfo.Enabled = False
   mnuBuddyAdd.Enabled = False
   mnuOtherChatFile = False
   mnuFilePassword.Enabled = False
   mnuBuddyRemove.Enabled = False
   mnuBuddyIgnore.Enabled = False
   mnuFileReport.Enabled = False

ElseIf mnuFileToggleLog.Caption = "登陆(&L)" Then

   Connect.Show 'ownerform:=Me
   Me.Hide

End If

End Sub

'===============
'修改用户信息
'================
Private Sub mnuFileChangeInfo_Click()
    '显示用户信息窗体
    frmSetInfo.Show
    '打开用户信息文件，填写相关信息到窗体
    Open "Info.dat" For Random As gFileNum Len = Len(MyPersonalInfo)
        Get #gFileNum, 1, MyPersonalInfo
        Dim Sex As String
        Dim Temp As String
        If MyPersonalInfo.Sex = "Male" Then
            frmSetInfo.Option1.value = True
        Else
            frmSetInfo.Option2.value = False
        End If
        frmSetInfo.Text1.Text = Trim(MyPersonalInfo.Country)    '国家
        frmSetInfo.Text2.Text = Trim(MyPersonalInfo.BirthDay)   '生日
        frmSetInfo.Text3.Text = Trim(MyPersonalInfo.Age)        '年龄
        frmSetInfo.Text4.Text = Trim(MyPersonalInfo.Webpage)     '主页
        Temp = Replace(Trim(MyPersonalInfo.About), "//crlf\\", vbCrLf)    '关于
        frmSetInfo.RichTextBox1.Text = Temp
    Close #gFileNum
End Sub

'=========
'连接到主页
'=========
Private Sub mnuHelpHomePage_Click()
    'Shell "start http://www.members.home.com/amjeb/index3.htm"
End Sub

'===============
'显示chatfile窗体
'===============
Private Sub mnuOtherChatFile_Click()
    frmChatFile.Show
End Sub

'============
'离开菜单，处理暂时离开事件
'===========
Private Sub mnuStatusAway_Click()

mnuStatusOnline.Checked = False
mnuStatusAway.Checked = True
mnuStatusDND.Checked = False
mnuStatusInvisible.Checked = False

Label1.Caption = "离开"
Winsock1.SendData ".status Offline"

End Sub

'=============
'免打扰状态
'==============
Private Sub mnuStatusDND_Click()

mnuStatusOnline.Checked = False
mnuStatusAway.Checked = False
mnuStatusDND.Checked = True
mnuStatusInvisible.Checked = False

Label1.Caption = "免打扰"
Winsock1.SendData ".status Away"

End Sub

'============
'隐身状态
'============
Private Sub mnuStatusInvisible_Click()

mnuStatusOnline.Checked = False
mnuStatusAway.Checked = False
mnuStatusDND.Checked = False
mnuStatusInvisible.Checked = True

Label1.Caption = "隐身"
Winsock1.SendData ".status Invisible"

End Sub

'============
'在线状态
'============
Private Sub mnuStatusOnline_Click()

mnuStatusOnline.Checked = True
mnuStatusAway.Checked = False
mnuStatusDND.Checked = False
mnuStatusInvisible.Checked = False

Label1.Caption = "在线"
Winsock1.SendData ".status Online"

End Sub

'=============
'双击好友列表
'=============
Private Sub TreeView1_DblClick()
On Error Resume Next

If TreeView1.SelectedItem.Text <> "" Then
   Dim NewIMessage As New IMessage    '定义一个新聊天窗口
   NewIMessage.Show ownerform:=Me       '显示窗口
   
   NewIMessage.Label2.Caption = TreeView1.SelectedItem
   NewIMessage.RecieversID = TreeView1.SelectedItem.Key
End If

End Sub

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)

On Error Resume Next

'显示右键菜单
If TreeView1.SelectedItem.Text <> "" Then
   PopupMenu mnuBuddy
End If

End Sub


'==============
'SOCKET关闭事件
'==============
Private Sub Winsock1_Close()

   mnuStatus.Enabled = False
   mnuBuddyMessage.Enabled = False
   Label1.Caption = "离线"      '显示离线状态
   Command1.Enabled = False
   Command2.Enabled = False
   BuddyUpdater.Enabled = False
   mnuFileToggleLog.Caption = "登陆(&L)"
   TreeView1.Nodes.Clear    '清空好友列表
   Winsock1.Close

End Sub

'===============
'SOCKET连接
'===============
Private Sub Winsock1_Connect()

   Command1.Enabled = True
   Command2.Enabled = True
   mnuFileToggleLog.Caption = "注销(&L)"

End Sub

'============
'接收SOCKET数据过程
'============
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

If Winsock1.State = 7 Then
    Dim ServerCommand As String
    '取得消息
    Winsock1.GetData ServerCommand
    'MsgBox ServerCommand
        '如果为filloutform消息，则显示改变用户信息窗口
        If Word(ServerCommand, 1) = ".FillOutForm" Then
            frmSetInfo.Show
            Connect.Hide
        End If
        
        '删除黑名单命令
        If Word(ServerCommand, 1) = ".ClearIgnoreList" Then frmIgnore.List1.Clear
        
        '添加黑名单命令
        If Word(ServerCommand, 1) = ".AddIgnore" Then frmIgnore.List1.AddItem Word(ServerCommand, 2)
        
        '连接命令
        If Word(ServerCommand, 1) = ".Connected" Then
            Connect.Label1.Caption = "用户名, 密码..."
            Dim Temp2 As String
            If Connect.Check1.value = 1 Then
                Temp2 = "Yes"
            Else
                Temp2 = "No"
            End If
            Winsock1.SendData ".login " & Connect.Text1 & " " & Connect.Text2 & " " & Temp2
        End If

        '离线命令
        If Word(ServerCommand, 1) = ".LogOff" Then
        
            mnuFileToggleLog.Caption = "登陆(&L)"
            '关闭SOCKET
            Winsock1.Close
            BuddyUpdater.Enabled = False
            Command1.Enabled = False
            Command2.Enabled = False
            Label1.Caption = "离线"
            TreeView1.Nodes.Clear
            mnuBuddyMessage.Enabled = False
            mnuStatus.Enabled = False
            'MsgBox "Server shutdown ... so now, so must you."
            'End
            
        End If
        
        '好友已经在列表中事件
        If Word(ServerCommand, 1) = ".AlreadyOnList" Then
            MsgBox "该用户已经在您的好友列表中!"
        End If
        
        '用户信息命令
        If Word(ServerCommand, 1) = ".UserInfo" Then
            Dim NewfrmInfo As New frmInfo
            NewfrmInfo.Caption = "Info on " & RemoteNick
            NewfrmInfo.Text1.Text = Word(ServerCommand, 2)
            NewfrmInfo.Text2.Text = Word(ServerCommand, 3)
            NewfrmInfo.Text3.Text = Word(ServerCommand, 4)
            NewfrmInfo.Text4.Text = Word(ServerCommand, 5)
            NewfrmInfo.RichTextBox1.TextRTF = MidWord(Replace(ServerCommand, "//crlf\\", vbCrLf), 6, Val(Words(ServerCommand)) - 6)
            NewfrmInfo.Text6.Text = Word(ServerCommand, Words(ServerCommand))
            NewfrmInfo.Show
        End If
        
        '发送文件命令
        If Word(ServerCommand, 1) = ".SendFile" Then
            
            FileSendRemoteIP = Word(ServerCommand, 2)
            
            On Error Resume Next
            CommonDialog.CancelError = True
            CommonDialog.ShowOpen
            
            If CommonDialog.fileName = "" Then Exit Sub
            
            Winsock1.SendData ".RecieveFile " & FileSendRemoteNick
            
            sendFile_01 CommonDialog.FileTitle, CommonDialog.fileName, FileSendRemoteIP, "1982", Connect.Text1.Text
            
        End If
        
        '接收文件命令
        If Word(ServerCommand, 1) = ".RecieveFile" Then
            
            receiveFile_01 Word(ServerCommand, 2), "1983"
            
        End If
        
        '实时聊天命令(作为服务端)
        If Word(ServerCommand, 1) = ".RTChat" Then
            
            Dim NewRTChat As New frmRTChat
            
            'RTCListen = False
            RTChatRemoteIP = Word(ServerCommand, 2)
            NewRTChat.Show
            NewRTChat.Caption = RTChatRemoteNick
            On Error Resume Next
            NewRTChat.Winsock1.Close   '关闭已经打开的SOCKET
            NewRTChat.Winsock1.RemotePort = "1981"
            NewRTChat.Winsock1.Connect RTChatRemoteIP ' 尝试连接
            NewRTChat.lblStatus.Caption = "连接到 " + txtRemoteIP.Text
            
        End If
        
        '实时聊天命令(客户端)
        If Word(ServerCommand, 1) = ".RTChat2" Then
            
            Dim NewRTChat2 As New frmRTChat
            
            RTChatTemp = Word(ServerCommand, 2)
            If Not RTChatTemp = Word(ServerCommand, 2) Then RTChatTemp = Word(ServerCommand, 2)
            Dim TempAnswer As Integer
            TempAnswer = MsgBox("Will you accept this chat request from " & RTChatTemp & ".", vbYesNo)
            DoEvents
            If TempAnswer = vbYes Then
                NewRTChat.Show
                NewRTChat.Caption = Word(ServerCommand, 2)
                NewRTChat.Winsock1.Close
                NewRTChat.Winsock1.LocalPort = "1981"
                NewRTChat.Winsock1.Listen '监听端口
                DoEvents
                Winsock1.SendData ".BeginRTChat " & RTChatTemp
                NewRTChat.lblStatus.Caption = "监听连接请求." ' Inform the user that we are listening for a connection request.
            Else
                '发送取消聊天命令
                Winsock1.SendData ".CancelRTChat " & RTChatTemp
            End If
            'RTCListen = True
            'RTChatTemp = Me.Caption
        
        End If
        
        '删除好友命令
        If Word(ServerCommand, 1) = ".RemoveBuddy" Then
        
          On Error Resume Next
          
          For i = 1 To TreeView1.Nodes.Count
             If InStr(1, TreeView1.Nodes(i).Key, Word(ServerCommand, 2)) Then
                TreeView1.Nodes.Remove i
                Exit For
             End If
          Next
          
        End If
        
        '连接成功命令
       If Word(ServerCommand, 1) = ".LoginGood" Then
    
          Connect.Label1.Caption = "连接服务器成功..."
          Unload Connect
          Me.Show
          
          '发送在线消息
          Winsock1.SendData ".status Online"
          Label1.Caption = "在线"
          mnuStatusOnline.Checked = True
          mnuBuddyMessage.Enabled = True
          mnuBuddyFile.Enabled = True
          mnuBuddyChat.Enabled = True
          mnuBuddyInfo.Enabled = True
          mnuFileChangeInfo.Enabled = True
          mnuBuddyAdd.Enabled = True
          mnuOtherChatFile = True
          mnuStatus.Enabled = True
          mnuFilePassword.Enabled = True
          mnuBuddyRemove.Enabled = True
          mnuBuddyIgnore.Enabled = True
          mnuFileReport.Enabled = True
          mnuStatusOnline.Checked = True
          mnuStatusAway.Checked = False
          mnuStatusDND.Checked = False
          mnuStatusInvisible.Checked = False
          
          DoEvents

          Winsock1.SendData ".getbuddys"

          BuddyUpdater.Enabled = True
        
       '连接失败
       ElseIf Word(ServerCommand, 1) = ".LoginBad" Then
    
          Dim reason As String
          
          reason = MidWord(ServerCommand, 4, Words(ServerCommand) - 4)
          
          Connect.Label1.Caption = "连接失败"
          Connect.Label2.Caption = "连接失败"
          
          If Word(ServerCommand, 2) = "0" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "用户名输入错误."
          ElseIf Word(ServerCommand, 2) = "1" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "密码错误，请重新输入"
          ElseIf Word(ServerCommand, 2) = "2" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "您的账号被封，因为 " & reason & ". 封锁将进行 " & Word(ServerCommand, 3) & " 天."
          ElseIf Word(ServerCommand, 2) = "3" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "您的账号被封，因为 " & reason & "."
          ElseIf Word(ServerCommand, 2) = "4" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "您的账号被注销, 因为 " & reason & "."
          ElseIf Word(ServerCommand, 2) = "5" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "服务器人满，请销后连接."
          ElseIf Word(ServerCommand, 2) = "6" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "同名用户已经连接."
          ElseIf Word(ServerCommand, 2) = "7" Then
             Connect.Label2.Caption = Connect.Label2.Caption & "服务器已关闭!"
          End If
          
          Connect.Label3.ForeColor = vbBlack
          Connect.Label4.ForeColor = vbBlack
          Connect.Text1.Enabled = True
          Connect.Text2.Enabled = True
          Connect.Command1.Enabled = True
          Connect.Command2.Caption = "关闭(&C)"
          Winsock1.Close
    
       
       ElseIf Word(ServerCommand, 1) = ".msg" Then
    
          Dim NewReponseMessage As New GotMessage
          NewReponseMessage.Show ownerform:=Me
    
          NewReponseMessage.Caption = "收到来自 " & Trim(Replace(Word(ServerCommand, 3), "_._", " "))
    
          NewReponseMessage.Label2.Caption = Trim(Replace(Word(ServerCommand, 3), "_._", " ")) & " (" & Trim(Word(ServerCommand, 2) & ")")
          NewReponseMessage.SenderID = Trim(Word(ServerCommand, 2))
          NewReponseMessage.SenderName = Trim(Replace(Word(ServerCommand, 3), "_._", " "))

          NewReponseMessage.RichTextBox1.TextRTF = Trim(Replace(SplitString(ServerCommand, "..//.."), "//crlf\\", vbCrLf))

       '刷新好友列表命令
       ElseIf Word(ServerCommand, 1) = ".pushbuddyupdate" Then
          On Error Resume Next
          
          For i = 1 To TreeView1.Nodes.Count
             If InStr(1, TreeView1.Nodes(i).Key, Word(ServerCommand, 2)) Then
                TreeView1.Nodes(i).Image = Word(ServerCommand, 3)
                TreeView1.Nodes(i).SelectedImage = Word(ServerCommand, 3)
                TreeView1.Refresh
                Exit For
             End If
          Next
      
       ElseIf Word(ServerCommand, 1) = ".pushbuddy" Then
          Dim BuddyUserID
          Dim BuddyUserTitle
          
          'MsgBox ServerCommand
       
          BuddyStatus = Word(ServerCommand, 2)
          BuddyUserID = Word(ServerCommand, 3)
          BuddyUserTitle = SplitString(ServerCommand, Word(ServerCommand, 3))
    
          'MsgBox "Server pushed user " & SplitString(ServerCommand, ".pushbuddy") & " to me!"
          On Error Resume Next
          TreeView1.Nodes.Add , tvwChild, BuddyUserID, BuddyUserTitle, BuddyStatus, BuddyStatus

       End If
      '清除好友命令
       If Word(ServerCommand, 1) = ".ClearBuddys" Then
       
          TreeView1.Nodes.Clear
          
       End If
       If Word(ServerCommand, 1) = ".msg2" Then
            
          NewReponseMessage.Show ownerform:=Me
          NewReponseMessage.Caption = "Message from " & Word(ServerCommand, 2)
          NewReponseMessage.Label2 = Word(ServerCommand, 2)
          NewReponseMessage.SenderID = Word(ServerCommand, 2)
          NewReponseMessage.SenderName = Word(ServerCommand, 2)
          NewReponseMessage.RichTextBox1.TextRTF = MidWord(ServerCommand, 3, Words(ServerCommand))
          
       End If
       If Word(ServerCommand, 1) = ".ServerMessage" Then
          MsgBox "ServerMessage:  " & MidWord(ServerCommand, 2, Words(ServerCommand))
       End If
End If
Exit Sub
DoNothing:
    If Err.Number = cdlCancel Then
        Exit Sub
    Else
        MsgBox Err.Description
    End If
End Sub