VB聊天工具

Posted on 2012-06-12 | In Program | | Visitors:

介绍

基于 udp 开发
使用 vb 开发
仅支持点对点对话，不支持多人，不是聊天室
支持来消息提醒功能
支持发送对话表情
支持发送文件（TCP）
VB 编程练手 TCP 和 UDP
本人和老婆认识时做的 2 人聊天工具（公司不能上网）
TCP/IP Winsock 状态表示
(0) sckClosed：关闭状态
(1) sckOpen：打开状态
(2) sckListening：侦听状态
(3) sckConnectionPending：连接状态
(4) sckResolvingHost：解析主机中
(5) sckHostResolved：已解析主机
(6) sckConnecting：正在连接
(7) sckConnected：已经连接
(8) sckClosing：客户端正在关闭
(9) sckError：连接发生错误

代码

Option Explicit
Const REG_SZ = 1
Const HKEY_LOCAL_MACHINE = &H80000002
Const WM_LBUTTONDOWN = &H201

'API定义
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function FlashWindow Lib "User32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Private Declare Function GetForegroundWindow Lib "User32" () As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
'定义变量
Dim info_ip As String
Dim info_name As String
Dim connect As Boolean
Dim localid As Long
Dim a As Boolean
Dim font_name, font_size, font_underline, font_strikethru, font_bold, font_italic, font_color
Dim onaccept As Boolean
Dim onsend As Boolean
Dim FileNumber As Integer
Dim client_LenFile As Long
Dim client_ProBarLen As Long
Dim client_VarPlus As Long
Dim GetFileNum As Integer
Dim server_LenFile As Long
Dim server_ProBarLen As Long
Dim server_VarPlus As Long

Private Sub client_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)
    client.Close
End Sub

Private Sub server_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)
    server.Close
End Sub

Private Sub fileclient_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)
    fileclient.Close
End Sub

Private Sub fileserver_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)
    fileserver.Close
End Sub

Private Sub Form_Load()
Dim FPath As String
Dim fontpath As String
Dim skinpath As String
Dim skin As String
Dim hKey As Long, ret As Long, lenData As Long, typeData As Long
Dim Name As String
Dim S As String
    onaccept = False
    onsend = False
    SendLabel.Caption = "Up:NaN"
    ReceiveLabel.Caption = "Down:NaN"
    Me.Caption = "For"
    On Error Resume Next
    '设置加载位置至屏幕中心
    Me.Left = (Screen.Width - Me.Width) / 2
    Me.Top = (Screen.Height - Me.Height) / 2
    '加载皮肤
    skinpath = App.path & "\Data\skin.ini"
    Open skinpath For Input As #1
    Input #1, skin
    Close #1
    Skin1.LoadSkin skin
    Skin1.ApplySkin Me.hWnd
    '调用自动调整控件大小模块
    Call ResizeInit(Me)
    '图片缓存区域RTF
    Richtemp.TextRTF = ""
    '系统默认字体，S为显示系统默认的字体
    If lang = "chs" Or lang = "cht" Then
        Name = "GUIFont.Facename"
        ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\GRE_Initialize", hKey)
        If ret = 0 Then
            ret = RegQueryValueEx(hKey, Name, 0, typeData, ByVal vbNullString, lenData) '注意ByVal千万别忘了
        End If
        S = String(lenData, Chr(0))
        ret = RegQueryValueEx(hKey, Name, 0, typeData, ByVal S, lenData) '注意ByVal千万别忘了
        S = Left(S, InStr(S, Chr(0)) - 1)
        '设置文本框的字体
        record.Font = S
        msg.Font = S
    End If
    FPath = App.path & "\Data\info.ini"
    fontpath = App.path & "\Data\font.ini"
    On Error GoTo errhandle
    '个人信息
    If Dir(FPath) = "" Then
        Open FPath For Output As #1
        Write #1, "127.0.0.1", "juan"
        Close #1
        remoteip.Text = "127.0.0.1"
        nickname.Text = "juan"
    Else
        Open FPath For Input As #1
        Input #1, info_ip, info_name
        Close #1
        remoteip.Text = info_ip
        nickname.Text = info_name
    End If
    '字体信息
    If Dir(fontpath) <> "" Then
        Open fontpath For Input As #1
        Input #1, font_name, font_size, font_underline, font_strikethru, font_bold, font_italic, font_color
        Close #1
    End If
    record.Font.Size = font_size
    msg.Font.Size = font_size
    '信息文本清空
    record.Text = ""
    msg.Text = ""
    With StatusBar
        .Panels(1).Text = "Local IP:" + server.LocalIP
    End With
    '打开监听端口
    Call setport
    Exit Sub
errhandle:
    MsgBox "load_Err:" + Err.Description
End Sub

Public Function lang() As String
    localid = GetSystemDefaultLCID
    Select Case localid
        Case &H404 '繁体语言
            lang = "cht"
        Case &H804 '简体语言
            lang = "chs"
        Case &H409 'English
            lang = "en"
    End Select
End Function

'设置client and server端口
Sub setport()
With server
    .LocalPort = 40000
    .Listen
End With
With client
    .LocalPort = 40001
    .RemotePort = 40000
End With
With fileserver
    .LocalPort = 40002
    .Listen
End With
With fileclient
    .LocalPort = 40003
    .RemotePort = 40002
End With
End Sub

Sub clientconnect()
With client
    .Close
    .RemoteHost = remoteip.Text
    .connect
End With
End Sub

Sub fileclientconnect()
With fileclient
    .Close
    .RemoteHost = remoteip.Text
    .connect
End With
End Sub

Private Sub Form_Activate()
    remoteip.SetFocus
End Sub

'界面大小重置
Private Sub Form_Resize()
    Call ResizeForm(Me)
    If Me.WindowState = 0 Then
        StatusBar.Panels(1).Width = Me.ScaleWidth * 0.5
        StatusBar.Panels(2).Width = Me.ScaleWidth * 0.5
    End If
End Sub

'界面卸载
Private Sub Form_Unload(Cancel As Integer)
    server.Close
    client.Close
    fileserver.Close
    fileclient.Close
    Call TrayRemoveIcon
End Sub

'字体
Private Sub Font_Click()
Dim FPath As String
On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlCFBoth Or cdlCFEffects
    CommonDialog1.ShowFont
    If Err = cdlCancel Then
        Exit Sub '对话框取消退出
    Else
        font_name = CommonDialog1.FontName
        font_size = CommonDialog1.FontSize
        font_underline = CommonDialog1.FontUnderline
        font_strikethru = CommonDialog1.FontStrikethru
        font_bold = CommonDialog1.FontBold
        font_italic = CommonDialog1.FontItalic
        font_color = CommonDialog1.Color
        '保存字体信息
        If CommonDialog1.Action = 0 Then
            FPath = App.path & "\Data\font.ini"
            Open FPath For Output As #1
            Write #1, font_name, font_size, font_underline, font_strikethru, font_bold, font_italic, font_color
            Close #1
        End If
    End If
End Sub

Private Sub min_Click()
On Error Resume Next
    Call TrayAddIcon(Me, Picture1, "For juan", NIIF_ICON_MASK)
    If min.Value = 1 Then
        Me.Visible = False '让程序界面不可见
        Call TrayIcon(Picture1(1).Picture)
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Static Message As Long
On Error Resume Next
'x   is   the   current   mouse   location   along   the   x-axis
Message = x / Screen.TwipsPerPixelX
If Me.Visible = False Then
Select Case Message
'   Left   double   click
Case WM_LBUTTONDOWN
    min.Value = 0
    Me.Visible = True
    If newmsgTimer.Enabled = True Then
    newmsgTimer.Enabled = False
    End If
    Call TrayRemoveIcon
End Select
End If
End Sub

'托盘图标闪烁
Private Sub newmsgTimer_Timer()
    a = Not a
    If a = True Then
        Call TrayIcon(Picture1(0).Picture)
    Else
        Call TrayIcon(Picture1(1).Picture)
    End If
End Sub

'client向server请求连接
Private Sub Request_Click()
Dim FPath As String
    connect = True
    FPath = App.path & "\Data\info.ini"
    On Error GoTo errhandle
    Call clientconnect  '文本信息连接
    Call fileclientconnect '文件发送连接
    If info_ip <> remoteip.Text Or info_name <> nickname.Text Then
        Open FPath For Output As #1
        Write #1, remoteip.Text, nickname.Text
        Close #1
    End If
    msg.SetFocus
    Exit Sub
errhandle:
    MsgBox "request_connect_Err:" + Err.Description
End Sub

'server连接请求
Private Sub server_ConnectionRequest(ByVal requestID As Long)
    remoteip = server.RemoteHostIP
    If MsgBox("request ip:" + remoteip, vbOKCancel) = vbOK Then
        remoteip.Text = remoteip
        If server.State <> sckClosed Then
             server.Close
             server.Accept requestID
        End If
    End If
End Sub

'发送文本信息
Private Sub send_Click()
On Error GoTo errhandle
Dim sendtext As String
Dim time As String
Dim record_length As Long
Dim msg_length As Long
Dim faceid As String
Dim facestart As Long
    time = Format(Now(), "hh:mm:ss")
    'format是格式化输出日期和时间格式函数,yyyy-mm-dd是完整显示年月日，hh:mm:ss是显示时分秒。
    sendtext = Replace(msg.Text, vbCrLf, "")
    sendtext = nickname.Text & " " & time & ":" & vbCrLf & sendtext & vbCrLf
    record_length = Len(record.Text)
    msg_length = Len(sendtext)
    record.SelStart = record_length
    Call AddText(record, sendtext, "")
    With record
        .SelStart = record_length
        .SelLength = msg_length
        'Dim font_name, font_size, font_underline, font_strikethru, font_bold, font_italic, font_color
        .SelFontName = font_name
        .SelFontSize = font_size
        .SelUnderline = font_underline
        .SelStrikeThru = font_strikethru
        .SelBold = font_bold
        .SelItalic = font_italic
        .SelColor = font_color
    End With
    msg.Text = ""
    '表情图片
    facestart = record.Find("/ali", record_length)
    If facestart > -1 Then
        faceid = Mid(record.Text, facestart + 2, 6)
        record.SelStart = facestart
        record.SelLength = 7
        Call facepic(Richtemp, faceid)
        record.SelText = Richtemp.TextRTF
        Call rich_backspace(record)
        Richtemp.TextRTF = ""
        msg.SetFocus
    End If
    record.SelStart = Len(record.Text)
    client.SendData sendtext
    Exit Sub
errhandle:
    MsgBox Err.Description
    Request.Enabled = True
End Sub

'server接收数据
Private Sub server_DataArrival(ByVal bytesTotal As Long)
Dim receivetext As String
Dim forehwnd As Long
Dim facestart As Long
Dim faceid As String
Dim record_length As Long
On Error Resume Next
    server.GetData receivetext
    record_length = Len(record.Text)
    record.SelStart = record_length
    Call AddText(record, receivetext, "")
    facestart = record.Find("/ali", record_length)
    If facestart > -1 Then
        faceid = Mid(record.Text, facestart + 2, 6)
        record.SelStart = facestart
        record.SelLength = 7
        Call facepic(Richtemp, faceid)
        record.SelText = Richtemp.TextRTF
        Call rich_backspace(record)
        Richtemp.TextRTF = ""
        msg.SetFocus
    End If
    record.SelStart = Len(record.Text)
    forehwnd = GetForegroundWindow()
    If Me.hWnd <> forehwnd Then
        Timer.Enabled = True
        Timer.Interval = 1000
    End If
    If min.Value = 1 And newmsgTimer.Enabled = False Then
        With newmsgTimer
            .Enabled = True
            .Interval = 500
        End With
    End If
End Sub

Private Sub servertimer_Timer()
    StatusBar.Panels(2).Text = "Connect Status" & "-" & server.State & client.State & fileserver.State & fileclient.State
    If client.State = 7 Or client.State = 6 Or fileclient.State = 7 Or fileclient.State = 6 Then
        If client.State = 7 And fileclient.State = 7 Then
        connect = False
        End If
        Request.Enabled = False
        If server.State = 7 And fileserver.State = 7 Then
            remoteip.Enabled = False
            nickname.Enabled = False
            StatusBar.Panels(2).Text = "Connect OK!" & "-" & server.State & client.State & fileserver.State & fileclient.State
        Else
            If client.State = 7 And fileclient.State = 7 Then
                StatusBar.Panels(2).Text = "Server Ok!" & "-" & server.State & client.State & fileserver.State & fileclient.State
            Else
                StatusBar.Panels(2).Text = "Connecting!" & "-" & server.State & client.State & fileserver.State & fileclient.State
            End If
        End If
    Else
        If server.State <> 2 And server.State <> 7 And fileserver.State <> 2 And fileserver.State <> 7 Then
            server.Close
            server.Listen
            fileserver.Close
            fileserver.Listen
        End If
        If connect = True Then
            If client.State <> 6 Then
                Call clientconnect
            End If
            If fileclient.State <> 6 Then
                Call fileclientconnect
            End If
            StatusBar.Panels(2).Text = "Connect retry!" & "-" & server.State & client.State & fileserver.State & fileclient.State
        Else
            If client.State = 8 Or fileclient.State = 8 Then
                client.Close
                fileclient.Close
                server.Close
                fileserver.Close
                Request.Enabled = True
                remoteip.Enabled = True
                nickname.Enabled = True
                StatusBar.Panels(2).Text = "Connect Closed!" & "-" & server.State & client.State & fileserver.State & fileclient.State
            End If
        End If
    End If
    If client.State = sckClosing Then
        client.Close
    End If
    If server.State = sckClosing Then
        server.Close
    End If
    If fileclient.State = sckClosing Then
        fileclient.Close
    End If
    If fileserver.State = sckClosing Then
        fileserver.Close
    End If
End Sub

Private Sub skin_Click()
Dim path As String
Dim skinpath As String
    skinpath = App.path & "\Data\skin.ini"
    With CommonDialog1
        .CancelError = True
        .DialogTitle = "Select Skin"
        On Error GoTo cancelerr
        .Filter = "Skin(*.skn)|*.skn"
        .InitDir = App.path & "\Data\Skins"
        .ShowOpen
        path = .FileName
    End With
    Open skinpath For Output As #1
    Write #1, path
    Close #1
    Skin1.RemoveSkin Me.hWnd
    Skin1.LoadSkin path
    Skin1.ApplySkin Me.hWnd
cancelerr:
End Sub

Private Sub Timer_Timer()
On Error Resume Next
    Call FlashWindow(Me.hWnd, True)
    If Me.WindowState <> vbMinimized Then
        Timer.Enabled = False
    End If
End Sub

Private Sub msg_KeyUp(KeyCode As Integer, Shift As Integer)
On Error Resume Next
    If KeyCode = 13 Then
        Call send_Click
        msg.Text = ""
    End If
End Sub

'截图调用
Private Sub Command1_Click()
On Error Resume Next
Dim path As String
    path = App.path & "\Data\Printscreen.exe"
    Shell path
End Sub

Private Sub fileclient_DataArrival(ByVal bytesTotal As Long)
Dim wskcommand As String
Dim cmdarr() As String
Dim filebyte() As Byte
If onaccept Then
    fileclient.GetData filebyte, vbArray + vbByte
    Put #FileNumber, , filebyte
    '------------进度显示----------
    client_VarPlus = client_VarPlus + (UBound(filebyte) + 1)
    ReceiveLabel.Caption = "Down:" & Left(Str((client_VarPlus / client_ProBarLen) * 100), 4) & "%"
    '------------------------------
    client_LenFile = client_LenFile - (UBound(filebyte) + 1)
    If client_LenFile = 0 Then
        onaccept = False
        Close #FileNumber
        MsgBox "receive ok!", vbInformation, "Tips"
    End If
    Exit Sub
End If
fileclient.GetData wskcommand
cmdarr = Split(wskcommand, ",")
If cmdarr(0) = "SendFile" Then
    If MsgBox("Do you want to receive file from remote client?", vbQuestion + vbYesNo, "File Tips") = vbYes Then
    With CommonDialog1
        .CancelError = True
        On Error GoTo saveerr
        .DialogTitle = "Save to..."
        .FileName = cmdarr(1)
        .Filter = "All Files(*.*)|*.*"
        .Flags = &H4 Or &H2
        .ShowSave
    End With
    fileclient.SendData "OkSend"
    client_LenFile = Val(cmdarr(2))
    client_ProBarLen = client_LenFile
    client_VarPlus = 0
    onaccept = True
    FileNumber = FreeFile
    Open CommonDialog1.FileName For Binary As #FileNumber
    Else
    fileclient.SendData "NoThanks"
    End If
End If
Exit Sub
saveerr:
    fileclient.SendData "NoThanks"
End Sub

'文件服务响应连接请求
Private Sub fileserver_ConnectionRequest(ByVal requestID As Long)
    If fileserver.State <> sckClosed Then
        fileserver.Close
        fileserver.Accept requestID
        End If
End Sub

'文件服务server响应
Private Sub fileserver_DataArrival(ByVal bytesTotal As Long)
Dim wskchat As String
fileserver.GetData wskchat
If wskchat = "NoThanks" Then
    MsgBox "Refused", vbExclamation, "server"
    ElseIf wskchat = "OkSend" Then
    MsgBox "accept" & vbCrLf & vbCrLf & "Click OK to receive", vbInformation, "server"
    GetFileNum = FreeFile
    server_LenFile = FileLen(Text1.Text)
    server_ProBarLen = server_LenFile
    server_VarPlus = 0
    Open Text1.Text For Binary As #GetFileNum
    onsend = True
    Call TCPSendFile(fileserver, GetFileNum, splitfile)
End If
End Sub

'文件服务winsock发送完成
Private Sub fileserver_SendComplete()
If onsend Then
If 0 = server_LenFile Then
    Close #GetFileNum
    onsend = False
    MsgBox "send complete!", vbInformation, "server"
    Else: Call TCPSendFile(fileserver, GetFileNum, splitfile)
End If
End If
End Sub

'文件分割
Private Function splitfile() As Long
Dim getcount As Long
If server_LenFile >= 8192 Then
    getcount = 8192
    server_LenFile = server_LenFile - getcount
Else
    getcount = server_LenFile
    server_LenFile = server_LenFile - getcount
End If
server_VarPlus = server_VarPlus + getcount
SendLabel.Caption = "Up:" & Left(Str((server_VarPlus / server_ProBarLen) * 100), 4) & "%"
splitfile = getcount
End Function

'发送文件
Private Sub TCPSendFile(objWinSock As Winsock, FileNumber As Integer, SendLen As Long)
    Dim filebyte() As Byte
    ReDim filebyte(SendLen - 1)
    Get #FileNumber, , filebyte
    objWinSock.SendData filebyte
End Sub

'请求发送
Private Sub Command2_Click()
With CommonDialog1
    .CancelError = True
    On Error GoTo openerr
    .DialogTitle = "Open"
    .Filter = "All Files(*.*)|*.*"
    .Flags = &H4
    .InitDir = App.path
    .ShowOpen
    Text1.Text = .FileName
End With
fileserver.SendData "SendFile," & Dir(Text1.Text) & "," & FileLen(Text1.Text)
openerr:
If Err.Number = 32755 Or Err.Number = 0 Then
Exit Sub
Else
MsgBox Err.Description & Err.Number
End If
End Sub

坚持原创技术分享，您的支持将鼓励我继续创作！

Post author: tosobright
Post link: http://www.soshare.cn/2012/06/12/120612-vb-chat/
Copyright Notice: All articles in this blog are licensed under CC BY-NC-SA 3.0 unless stating additionally.

4 categories

26 tags

1. 介绍
2. 代码