VB 利用UDP制作简单的点对点聊天程序

原创 2007年10月01日 19:24:00

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmMain
   BorderStyle     =   1  'Fixed Single
   Caption         =   "点对点聊天 "
   ClientHeight    =   5175
   ClientLeft      =   45
   ClientTop       =   360
   ClientWidth     =   6720
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   5175
   ScaleWidth      =   6720
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer timerCheckConnect
      Enabled         =   0   'False
      Interval        =   10000
      Left            =   2160
      Top             =   4560
   End
   Begin VB.TextBox textSend
      Height          =   1455
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   4
      Top             =   3000
      Width           =   6495
   End
   Begin VB.CommandButton cmdConnect
      Caption         =   "连接(&C)"
      Default         =   -1  'True
      Height          =   375
      Left            =   5640
      TabIndex        =   2
      Top             =   160
      Width           =   975
   End
   Begin VB.TextBox textPort
      Height          =   270
      Left            =   4440
      TabIndex        =   1
      Text            =   "5300"
      Top             =   200
      Width           =   855
   End
   Begin MSWinsockLib.Winsock wsk
      Left            =   1320
      Top             =   4680
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.CommandButton cmdExit
      Cancel          =   -1  'True
      Caption         =   "退出(&X)"
      Height          =   375
      Left            =   5640
      TabIndex        =   6
      Top             =   4640
      Width           =   975
   End
   Begin VB.CommandButton cmdSend
      Caption         =   "发送(&S)"
      Height          =   375
      Left            =   4680
      TabIndex        =   5
      Top             =   4640
      Width           =   975
   End
   Begin VB.TextBox textAddress
      Height          =   270
      Left            =   1440
      TabIndex        =   0
      Top             =   200
      Width           =   1695
   End
   Begin VB.TextBox textMessage
      Height          =   2175
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   3
      Top             =   680
      Width           =   6495
   End
   Begin VB.Label Label1
      Caption         =   "输入聊天端口:"
      Height          =   255
      Left            =   3240
      TabIndex        =   8
      Top             =   240
      Width           =   1215
   End
   Begin VB.Label lMsg
      Caption         =   "输入聊天的IP:"
      Height          =   255
      Left            =   120
      TabIndex        =   7
      Top             =   240
      Width           =   1335
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'发送消息函数
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'使滚动条自动下拉
Private Const WM_VSCROLL = &H115
Private Const SB_BOTTOM = 7
'标识对方是否在线
Private isOnline As Boolean
'动画窗体(使指定窗体闪动好提示对方有消息来了)
Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long
'验证IP的合法性
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
'显示XP风格函数
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Sub Form_Initialize()
    '显示XP风格
    InitCommonControls
End Sub

Private Sub cmdConnect_Click()
    'IP地址不能为空
    If textAddress.Text = "" Then
        MsgBox "请输入对方的IP地址或者计算机名!!", vbCritical, "错误"
        textAddress.SetFocus
        Exit Sub
    Else
        '当是以IP地址连接方式下
        If InStr(textAddress.Text, ".") Then
            '当IP地址不合法
            If inet_addr(textAddress.Text) = -1 Then
                MsgBox "请检查你的IP合法性!!", vbCritical, "提示"
                '选择输入的字符串
                textAddress.SelStart = 0
                textAddress.SelLength = Len(textAddress.Text)
                textAddress.SetFocus
                Exit Sub
            End If
        End If
    End If
    '端口不能为空
    If textPort.Text = "" Then
        MsgBox "请输入聊天的端口号!!", vbCritical, "错误"
        textPort.SetFocus
        Exit Sub
    Else
        '端口必须是数字
        If Not IsNumeric(textPort.Text) Then
            MsgBox "请输入1-65536之间的数字!!", vbCritical, "错误"
            '选择输入的字符串
            textPort.SelStart = 0
            textPort.SelLength = Len(textPort.Text)
            textPort.SetFocus
            Exit Sub
        Else
            '对数字进行验证
            If CLng(textPort.Text) < 1 And CLng(textPort.Text) > 65536 Then
                MsgBox "请输入1-65536之间的数字!!", vbCritical, "错误"
                textPort.SetFocus
                Exit Sub
            End If
        End If
    End If
    '连接对方发送在线消息(在连接前先断开连接)
    wsk.Close
    '指明自己的连接端口
    wsk.LocalPort = textPort.Text
    '对方的连接端口
    wsk.RemotePort = textPort.Text
    '对方的IP或者计算机名
    wsk.RemoteHost = textAddress.Text
    wsk.Bind
    '发送在线消息
    wsk.SendData "Online**^_^**" & wsk.LocalIP
    '禁用连接按钮和IP地址栏以及端口
    textAddress.Enabled = False
    textPort.Enabled = False
    cmdConnect.Enabled = False
    timerCheckConnect.Enabled = True
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Public Sub cmdSend_Click()
    Dim strSend As String
    '发送消息给对方
    If textSend.Text <> "" Then
        '验证IP和端口
        If textAddress.Text <> "" And textPort.Text <> "" Then
            '判断是否在线
            If isOnline Then
                strSend = ReplaceExceptiveString(textSend.Text)
                wsk.SendData strSend & "**^_^**" & wsk.LocalIP
                textMessage.Text = textMessage.Text & vbNewLine & wsk.LocalIP & " " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & vbNewLine & textSend.Text
                textSend.Text = vbNullString
                SendMessage textMessage.hwnd, WM_VSCROLL, SB_BOTTOM, 0
            Else
                '如果不在线恢复可用连接状态
                MsgBox "对方不在线上!!", vbCritical, "提示"
                cmdConnect.Enabled = True
                textAddress.Enabled = True
                textPort.Enabled = True
            End If
        Else
            MsgBox "请检查IP地址和端口号是否合法!!", vbCritical, "提示"
            'Exit Sub
        End If
    End If
End Sub

'替换特殊字符串函数
Private Function ReplaceExceptiveString(ByVal strCheck As String) As String
    '这里替换的字符我用chr(0)因为正常是输入不了这个字符的
    If Left(strCheck, 13) = "Online**^_^**" Then
        ReplaceExceptiveString = String(8, Chr(0)) & Mid(strCheck, 14, Len(strCheck) - 13)
    ElseIf Left(strCheck, 15) = "OnlineOK**^_^**" Then
        ReplaceExceptiveString = String(10, Chr(0)) & Mid(strCheck, 16, Len(strCheck) - 15)
    ElseIf Left(strCheck, 12) = "Leave**^_^**" Then
        ReplaceExceptiveString = String(6, Chr(0)) & Mid(strCheck, 13, Len(strCheck) - 12)
    Else
        ReplaceExceptiveString = strCheck
    End If
End Function

'还原特殊字符串函数
Private Function RestoreExceptiveString(ByVal strCheck As String) As String
    If Left(strCheck, 10) = String(10, Chr(0)) Then
        RestoreExceptiveString = "OnlineOK**^_^**" & Mid(strCheck, 11, Len(strCheck) - 10)
    ElseIf Left(strCheck, 8) = String(8, Chr(0)) Then
        RestoreExceptiveString = "Online**^_^**" & Mid(strCheck, 9, Len(strCheck) - 8)
    ElseIf Left(strCheck, 6) = String(6, Chr(0)) Then
        RestoreExceptiveString = "Leave**^_^**" & Mid(strCheck, 7, Len(strCheck) - 6)
    Else
        RestoreExceptiveString = strCheck
    End If
End Function

Private Sub Form_Load()
    hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, App.hInstance, App.ThreadID)
    '指定协议类型为UDP
    wsk.Protocol = sckUDPProtocol
    '锁住信息显示栏
    Me.textMessage.Locked = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnhookWindowsHookEx hHook
    '当退出程序发送离线消息
    On Error Resume Next
    wsk.SendData "Leave**^_^**" & wsk.LocalIP
End Sub

'检测对方是否在线
Private Sub timerCheckConnect_Timer()
    If Not isOnline Then
        MsgBox "对方不在线,或者是网络有问题!!", vbCritical, "错误"
        '恢复可连接状态
        textAddress.Enabled = True
        textPort.Enabled = True
        cmdConnect.Enabled = True
        timerCheckConnect.Enabled = False
    End If
End Sub

'Winsock消息接收事件
Private Sub wsk_DataArrival(ByVal bytesTotal As Long)
    '消息过滤
    Dim strMessage As String, strArray() As String
    On Error Resume Next
    '接收类型为字符串
    wsk.GetData strMessage, vbString
    '格式化字符串(自定义协议的时候可以根据自己的爱好,但是在分割字符串的符号上最好是不要太容易重复的标识以防消息判断错误)
    strArray = Split(strMessage, "**^_^**")
    '如果是上线消息
    If Left(strMessage, 13) = "Online**^_^**" Then
        If textMessage.Text <> "" Then
            textMessage.Text = textMessage.Text & vbNewLine & strArray(1) & " 在 " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & " 上线了!!" & vbNewLine
        Else
            textMessage.Text = strArray(1) & " 在 " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & " 上线了!!" & vbNewLine
        End If
        '给对方发送你已经在线了
        wsk.SendData "OnlineOK**^_^**" & wsk.LocalIP
        '设置处于上线状态
        isOnline = True
        '关闭检测在线记时器
        timerCheckConnect.Enabled = False
        '自动下来滚动条
        SendMessage textMessage.hwnd, WM_VSCROLL, SB_BOTTOM, 0
        '扇动窗体好知道有消息来了
        FlashWindow Me.hwnd, 1
        '禁用连接按钮和IP地址栏以及端口
        textAddress.Enabled = False
        textPort.Enabled = False
        cmdConnect.Enabled = False
        '接收到对方已经在线了
    ElseIf Left(strMessage, 15) = "OnlineOK**^_^**" Then
        '显示对方已经在线了
        If textMessage.Text <> "" Then
            textMessage.Text = textMessage.Text & vbNewLine & strArray(1) & " 在 " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & " 上线了!!" & vbNewLine
        Else
            textMessage.Text = strArray(1) & " 在 " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & " 上线了!!" & vbNewLine
        End If
        '设置在线标识
        isOnline = True
        '关闭检测在线记时器
        timerCheckConnect.Enabled = False
        '自动下来滚动条
        SendMessage textMessage.hwnd, WM_VSCROLL, SB_BOTTOM, 0
        '扇动窗体好知道有消息来了
        FlashWindow Me.hwnd, 1
        '禁用连接按钮和IP地址栏以及端口
        textAddress.Enabled = False
        textPort.Enabled = False
        cmdConnect.Enabled = False
    ElseIf Left(strMessage, 12) = "Leave**^_^**" Then
        '当对方离线了
        If textMessage.Text <> "" Then
            textMessage.Text = textMessage.Text & vbNewLine & strArray(1) & " 在 " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & " 离线了!!" & vbNewLine
        Else
            textMessage.Text = strArray(1) & " 在 " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & " 离线了!!" & vbNewLine
        End If
        '设置离线标识
        isOnline = False
        '恢复可连接状态
        textAddress.Enabled = True
        textPort.Enabled = True
        cmdConnect.Enabled = True
        '自动下来滚动条
        SendMessage textMessage.hwnd, WM_VSCROLL, SB_BOTTOM, 0
        '扇动窗体好知道有消息来了
        FlashWindow Me.hwnd, 1
    Else
        '一般聊天内容
        textMessage.Text = textMessage.Text & vbNewLine & strArray(1) & " " & Format(Now, "yyyy年-mm月-dd日 HH:MM:SS") & vbNewLine & RestoreExceptiveString(strArray(0)) & vbNewLine
        '自动下来滚动条
        SendMessage textMessage.hwnd, WM_VSCROLL, SB_BOTTOM, 0
        '扇动窗体好知道有消息来了
        FlashWindow Me.hwnd, 1
    End If
End Sub

Private Sub wsk_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)
    '当有错误产生显示错误信息
    MsgBox Description
    '恢复可连接状态
    textAddress.Enabled = True
    textPort.Enabled = True
    cmdConnect.Enabled = True
End Sub

 

Attribute VB_Name = "modKeyBoard"
Option Explicit

Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_SYSKEYDOWN = &H104
Private Const WM_SYSKEYUP = &H105
Public Const WH_KEYBOARD = 2
Private Const VK_CONTROL = &H11
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public hHook As Long

Public Function KeyboardProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If idHook < 0 Then
        KeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
    Else
        If (GetKeyState(VK_CONTROL) And &H8000) And wParam = 13 Then
            If frmMain.textSend.Text <> "" Then frmMain.cmdSend_Click
            KeyboardProc = 1
            Exit Function
        End If
        KeyboardProc = CallNextHookEx(hHook, idHook, wParam, ByVal lParam)
    End If
End Function


 

相关文章推荐

C#.net udp 点对点聊天程序

  • 2012年04月06日 13:43
  • 44KB
  • 下载

MFC实现简单点对点聊天程序

//************************TALKCDlg.h________________________客户端 // TALKCDlg.h : 头文件 //   #if...

基于VB下的简易点对点聊天程序

  • 2015年01月07日 22:47
  • 210KB
  • 下载

Java基于UDP用Socket实现点对点聊天

基于UDP的聊天实现,采用读,写分离,用不同的线程实现。 主要实现类为DatagramSocket()与DatagramPacket(),默认端口为8009,Ip地址需要自己输入。 Reader线...

UDP点对点聊天

  • 2008年06月08日 19:15
  • 1.21MB
  • 下载

javaweb webSocket 实现简单的点对点聊天功能

本文依据 http://redstarofsleep.iteye.com/blog/1488639?page=4  内容修改完成,实现点对点聊天 需要 jdk 7 , tomcat需要支持web...

UDP协议点对点聊天工具

  • 2006年02月23日 09:05
  • 2.72MB
  • 下载
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:VB 利用UDP制作简单的点对点聊天程序
举报原因:
原因补充:

(最多只允许输入30个字)