form1.frm

该方案充分发挥人性化的特点

    RxBuf = "设置:打开串行口" + Chr(13) + Chr(10) + "Success to Join ZigBeeNet" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    Call StringShow(RxBuf)
    RxBuf = "凌阳科技-1，说：" + Chr(13) + Chr(10) + "凌阳科技-大学计划-ZigBee无线QQ测试" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    MsgName = 1
    Call StringShow(RxBuf)
    RxBuf = "凌阳科技-2，说：" + Chr(13) + Chr(10) + "收到“凌阳科技-大学计划-ZigBee无线QQ测试”，测试成功" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    MsgName = 2
    Call StringShow(RxBuf)
    RxBuf = "User <凌阳科技-2> Changed Name to <Fly流星>" + Chr(13) + Chr(10)
    MsgName = 0
    Call StringShow(RxBuf)
    RxData = "凌阳科技-1，说：" + Chr(13) + Chr(10) + "\\1凌阳科技-大学计划-测试表情发送\\3" + Chr(13) + Chr(10) + Chr(13) + Chr(10)
    MsgName = 1
    'Call MsgShow
End Sub
Private Sub Form_Load()
With nfIconData
.hwnd = Me.hwnd
.uID = Me.Icon
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon.Handle
'定义鼠标移动到托盘上时显示的Tip
.szTip = "SunPlus ZigBee无线QQ" & vbNullChar
.cbSize = Len(nfIconData)
End With
OnTop = 0
intCommPort = 1                                     '设置串行口号
strCommSettings = "9600,n,8,1"                      '设置波特率.奇偶校验位.数据位和停止位

RxBuf = ""
MyName = ""
JoinName = "*&^%$#@!~"
Call Shell_NotifyIcon(NIM_ADD, nfIconData)          '在托盘处显示图标

CtrlPressed = False
AltPressed = False

ButtonUpSign = False
'Call test

End Sub

'*************************************************
'设置串行口
'为参数设置提供公共接口
'*************************************************

Public Sub SetComm(strSet As String, intPort As Long)
    strCommSettings = strSet
    intCommPort = intPort
    
End Sub

'*************************************************
'获取串行口设置
'返回串口设置（波特率等）
'*************************************************

Public Function GetSettings() As String
    GetSettings = strCommSettings
    
End Function

'**************************************************
'获取当前串口号
'
'**************************************************

Public Function GetCommPort() As Long
    GetCommPort = intCommPort
End Function

'*************************************************
'打开串行口
'
'*************************************************
Public Sub CommPortOpen()
    
    On Error GoTo PortError
    
    MSComm1.CommPort = intCommPort                          '设置串行口号
    If MSComm1.PortOpen = True Then
        MSComm1.PortOpen = False
    End If
    MSComm1.Settings = strCommSettings                      '设置波特率.奇偶校验位.数据位和停止位
    MSComm1.InBufferSize = 1024                             '设置接收缓冲区的字节长度
    MSComm1.InBufferCount = 0                               '清除接收缓冲区数据
    MSComm1.OutBufferSize = 512                             '设置发送缓冲区字节长度
    MSComm1.OutBufferCount = 0                              '清除发送缓冲区数据
    MSComm1.RThreshold = 0 'sign 1                          '每次接收到字符即产生OnComm事件
    MSComm1.Handshaking = comNone 'sign comRTSXOnXOff       '如果有握手协议，硬件连接相应引脚必须连接并有效
    Form1.MSComm1.InputLen = 100
    MSComm1.PortOpen = True

PortError:
    Select Case Err.Number
        Case 8005
            MsgBox ("该串口已经被占用,请换其它串口!")
    End Select

End Sub


'*************************************************
'关闭串行口
'
'*************************************************
Public Sub CommPortClose()
    
    Dim strTemp As String
    
    If MSComm1.PortOpen = True Then
        MSComm1.PortOpen = False
        strTemp = "设置:关闭串行口!" + Chr(13) + Chr(10)
        Call StringShow(strTemp)
    Else
        strTemp = "设置:串行口已关闭!" + Chr(13) + Chr(10)
        Call StringShow(strTemp)
        
    End If
    
    
End Sub

'**************************************************
'打开串口
'响应菜单，打开串行口并向用户显示相关信息
'**************************************************

Private Sub OpenPort_Click()

    Dim strTemp As String
    
    If Form1.MSComm1.PortOpen = False Then
    
        Call CommPortOpen
        strTemp = "设置:打开串行口!" + Chr(13) + Chr(10)
        Call StringShow(strTemp)
        blnReceiveFlag = True
        intCommFlag = 1
    Else
        strTemp = "设置:串行口已经打开!" + Chr(13) + Chr(10)
        Call StringShow(strTemp)
    End If
    
End Sub
'************************************************
'信息显示处理
'记录发送接收及串口设置信息，保存显示格式（颜色）
'************************************************

Public Sub ReceiveDisplay(strAdd As String, intColor As Long)
    
    intArrayCount = intArrayCount + 2               '收到新信息,信息记录计数增加
    
    ReDim Preserve intColorSet(intArrayCount)       '重定义纪录数组,保留原有数据
    
    intColorSet(intArrayCount - 1) = Len(rtfReceive.Text)   '添加新数据(格式位置)
    intColorSet(intArrayCount) = intColor                   '格式类型
    
    rtfReceive.Text = rtfReceive.Text + strAdd + Chr(13)    '加入新信息并设置换行
    
    For n = 1 To intArrayCount - 1 Step 2                   '显示
        rtfReceive.SelStart = intColorSet(n)
        If n < intArrayCount - 1 Then
            rtfReceive.SelLength = intColorSet(n + 2) - intColorSet(n)
        Else
            rtfReceive.SelLength = Len(rtfReceive.Text) - intColorSet(n)
        End If
        
        Select Case intColorSet(n + 1)
            Case 1
                rtfReceive.SelColor = RGB(0, 255, 0)
            Case 2
                rtfReceive.SelColor = RGB(255, 0, 0)
            Case 3
                rtfReceive.SelColor = RGB(0, 0, 255)
        End Select
        
   Next n
    
End Sub


Private Sub Faceimage_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    Faceimage.Item(Index).Picture = LoadPicture(App.Path & "\Picture\表情\" + Chr(Index + 48) + "-2.bmp")
End Sub

Private Sub Faceimage_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    Faceimage.Item(Index).Picture = LoadPicture(App.Path & "\Picture\表情\" + Chr(Index + 48) + ".bmp")
    Call CheckCursUp(Form1.Faceimage(Index).Left, Form1.Faceimage(Index).Top, Form1.Faceimage(Index).Width, Form1.Faceimage(Index).Height)
    If ButtonUpSign = True Then
        Form1.rtfSend.SelStart = LenB(StrConv(Form1.rtfSend.Text, vbFromUnicode))
        Form1.rtfSend.SelText = "\\" + Chr(Index + 48)
    End If
End Sub


Private Sub Image2_DblClick()
    If MSComm1.PortOpen = True Then
       MSComm1.PortOpen = False
    End If
    Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
    End
End Sub

Private Sub Minimize_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Minimize.Picture = LoadResPicture("MINIMIZE2", 0)
End Sub

Private Sub Minimize_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Minimize.Picture = LoadResPicture("MINIMIZE1", 0)
    Call CheckCursUp(Form1.Minimize.Left, Form1.Minimize.Top, Form1.Minimize.Width, Form1.Minimize.Height)
    If ButtonUpSign = True Then
        Call Shell_NotifyIcon(NIM_ADD, nfIconData)
        Me.Hide
    End If
End Sub

Private Sub rtfSend_KeyDown(KeyCode As Integer, Shift As Integer)
    'SendKeys "%{F4}", True   '向系统发送Alt+F4
    If Shift And vbAltMask Then
        AltPressed = True
    End If
    If Shift And vbCtrlMask Then
        CtrlPressed = True
    End If
    
    If AltPressed And KeyCode = 83 Then
        If rtfSend.Text <> "" Then
            If rtfSend.Text = "cls" Then
                rtfReceive.Text = ""
                rtfSend.Text = ""
            Else
                If MSComm1.PortOpen = True Then MSComm1.Output = rtfSend.Text + "#"
                rtfSend.Text = ""
            End If
        End If
    End If
    If CtrlPressed And KeyCode = 13 Then
        If rtfSend.Text <> "" Then
            If rtfSend.Text = "cls" Then
                rtfReceive.Text = ""
                rtfSend.Text = ""
            Else
                If MSComm1.PortOpen = True Then MSComm1.Output = rtfSend.Text + "#"
                rtfSend.Text = ""
            End If
        End If
    End If
    
End Sub

Private Sub rtfSend_KeyUp(KeyCode As Integer, Shift As Integer)
    If CtrlPressed = True Then CtrlPressed = False
    If AltPressed = True Then AltPressed = False
End Sub

Private Sub SetCOM_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    SetCom.Picture = LoadResPicture("SETCOM2", 0)
End Sub

Private Sub SetCOM_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    SetCom.Picture = LoadResPicture("SETCOM1", 0)
    Call CheckCursUp(Form1.SetCom.Left, Form1.SetCom.Top, Form1.SetCom.Width, Form1.SetCom.Height)
    If ButtonUpSign = True Then
        frmConfig.Show
    End If
End Sub

Private Sub NewChat_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    NewChat.Picture = LoadResPicture("CREATE2", 0)
End Sub
Private Sub NewChat_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    NewChat.Picture = LoadResPicture("CREATE1", 0)
    Call CheckCursUp(Form1.NewChat.Left, Form1.NewChat.Top, Form1.NewChat.Width, Form1.NewChat.Height)
    If ButtonUpSign = True Then
        Call OpenPort_Click
        MSComm1.Output = "Create*" + "#"
    End If
End Sub



Private Sub JoinChat_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    JoinChat.Picture = LoadResPicture("JOIN2", 0)
End Sub

Private Sub JoinChat_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    JoinChat.Picture = LoadResPicture("JOIN1", 0)
    Call CheckCursUp(Form1.JoinChat.Left, Form1.JoinChat.Top, Form1.JoinChat.Width, Form1.JoinChat.Height)
    If ButtonUpSign = True Then
        Call OpenPort_Click
        MSComm1.Output = "Join*" + "#"
    End If
End Sub

Private Sub SetName_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    SetName.Picture = LoadResPicture("SETNAME2", 0)
End Sub

Private Sub SetName_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    SetName.Picture = LoadResPicture("SETNAME1", 0)
    Call CheckCursUp(Form1.SetName.Left, Form1.SetName.Top, Form1.SetName.Width, Form1.SetName.Height)
    If ButtonUpSign = True Then
        If MSComm1.PortOpen = True Then MSComm1.Output = "Name=" & NameText.Text & "*" + "#"
        NameText.Text = ""
    End If
End Sub
Private Sub Send_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Send.Picture = LoadResPicture("SEND2", 0)
End Sub

Private Sub Send_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Send.Picture = LoadResPicture("SEND1", 0)
    Call CheckCursUp(Form1.Send.Left, Form1.Send.Top, Form1.Send.Width, Form1.Send.Height)
    If ButtonUpSign = True Then
        If rtfSend.Text <> "" Then
            If rtfSend.Text = "cls" Then
                rtfReceive.Text = ""
                rtfSend.Text = ""
            Else
                If MSComm1.PortOpen = True Then MSComm1.Output = rtfSend.Text + "#"
                rtfSend.Text = ""
            End If
        End If
    End If
End Sub

Private Sub SetOnTop_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If OnTop = 1 Then
        SetOnTop.Picture = LoadResPicture("ONTOPCANCEL2", 0)
    Else
       SetOnTop.Picture = LoadResPicture("ONTOP2", 0)
   End If
End Sub

Private Sub SetOnTop_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call CheckCursUp(Form1.SetOnTop.Left, Form1.SetOnTop.Top, Form1.SetOnTop.Width, Form1.SetOnTop.Height)
    If ButtonUpSign = True Then
        If OnTop = 1 Then
            SetOnTop.Picture = LoadResPicture("ONTOP1", 0)
            SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, _
                SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
            OnTop = 0
        Else
            SetOnTop.Picture = LoadResPicture("ONTOPCANCEL1", 0)
            SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
                SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
            OnTop = 1
        End If
    Else
        If OnTop = 1 Then
            SetOnTop.Picture = LoadResPicture("ONTOPCANCEL1", 0)
        Else
            SetOnTop.Picture = LoadResPicture("ONTOP1", 0)
        End If
    End If
End Sub

Private Sub MSComm1_OnComm()
    Dim lenthtmp As Integer
    If MSComm1.InBufferCount > 1 Then
        RxBuf = MSComm1.Input
        Do
            vb218Flag = InStr(RxBuf, Chr(218))
            RxBuf = Mid(RxBuf, vb218Flag + 1)
        Loop While vb218Flag > 0
            RxData = Mid(RxBuf, 1)
            If InStr(RxData, "SetUser=") Then
                MyName = Mid(RxData, 9)
                NameLength = Len(MyName) 'len而不可用lenb
                MyName = Mid(MyName, 1, NameLength - 2)
            ElseIf InStr(RxData, "JoinUser=") Then
                JoinName = Mid(RxData, 10)
                JoinNameLength = Len(JoinName)
                JoinName = Mid(JoinName, 1, JoinNameLength - 2)
                MSComm1.Output = "Host=" + MyName + "#"
            ElseIf InStr(RxData, "Host=") Then
                JoinName = Mid(RxData, 6)
                JoinNameLength = Len(JoinName)
                JoinName = Mid(JoinName, 1, JoinNameLength - 2)
            Else
               If InStr(RxData, MyName) > 0 Then
                   MsgName = 1
               ElseIf InStr(RxData, JoinName) > 0 Then
                   MsgName = 2
               Else
                   MsgName = 3
               End If
               Call MsgShow
            End If
            RxData = ""
            RxBuf = ""
    End If
End Sub

Private Sub rtfReceive_DblClick()
With CommonDialog1
        .Filter = "所有文件(*.*)|*.*"
        .ShowSave
        On Error GoTo S_Err
    End With
    Open CommonDialog1.FileName For Output As #1
    Print #1, rtfReceive.Text
    Close #1
    Exit Sub
S_Err:
End Sub

Private Sub Timer1_Timer() '时间间隔为50，获得鼠标的X，Y座标和窗体位置 Enabled=True
    Dim n As POINTAPI
    GetCursorPos n
    mXd = n.x  '把鼠标X座标的值给 mXd 变量
    mYd = n.y  '把鼠标Y座标的值给 mYd 变量
    formXd = Form1.Left '把本窗体form1的Left值给 formXd 变量
    formYd = Form1.Top  '把本窗体form1的 ToP值给 formYd 变量
End Sub

Private Sub Timer2_Timer() '时间间隔10 Enabled=False
'以下的减法是为了让窗体和鼠标能同步

Form1.Left = mXd * 15 - (mXj - formXj) '本窗体form1的Left值=鼠标的 X 座标 * 15 -（鼠标x座标-窗体left位置）
Form1.Top = mYd * 15 - (mYj - formYj)  '本窗体form1的 Top值=鼠标的 Y 座标 * 15 -（鼠标y座标-窗体top位置）
End Sub

'==================废客联邦提供==================