对聊.frm

一个VB编写的校园即时广播系统,具有简单的定时广播性能

Call DeleteKey(HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\Extensions\{11111111-f40a-11d1-b792-444553540001}")
End If
End Sub

Private Sub l1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Chrs As String
Chrs = "二人世界(&T)"
If Button = 2 Then
If Len(Selectuser) = 0 Then Exit Sub
tweworld.Caption = "与" & Selectuser & "进入" & Chrs
SSound.Caption = "发语音消息给" & Selectuser
lysend.Caption = "留言给" & Selectuser
PopupMenu usermenu, vbPopupMenuLeftAlign, 4500
End If
End Sub

Private Sub L1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If L1.ListCount = 0 Then Exit Sub
Dim pos As Long, idx As Long
    pos = X / Screen.TwipsPerPixelX + Y / Screen.TwipsPerPixelY * 65536
    idx = SendMessage(L1.hwnd, LB_ITEMFROMPOINT, 0, ByVal pos)
     If idx < 65536 Then
     For a = 0 To L1.ListCount - 1
     If L1.List(a) = L1.List(idx) Then
     L1.Selected(a) = True
     If Button = 0 Then
     Selectuser = L1.List(a)
     End If
     Exit Sub
     End If
     Next
     End If
End Sub

Private Sub LastSound_Click()
sndPlaySound Tempath & "\Sound\RTmp", &H1 Or &H2
End Sub

Private Sub lysend_Click()
Dim lymag As String
lymag = Left(Trim(InputBox("请输入要留言的内容,最多20个字", "留言")), 20)
If lymag <> "" Then
W1.SendData "lyma" & Selectuser & "~" & Locateuser & "留言:" & lymag
DoEvents
End If
End Sub

Private Sub mini_Click()
Me.Visible = False
Command2.Caption = "复原"
a = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
t1.Enabled = False
ArrowVisual False
AllNewVisual False
Command4.Visible = False
BlackVisual False
With Me
.Height = 800
.Width = Screen.Width
.Top = 0
.Left = 0
End With
With ht
.Top = 5
.Height = 470
.Width = Me.Width - Command2.Width
End With
Command2.Left = Me.Width - Command2.Width - 60
L1.Visible = False
Me.Visible = True
a = SetWindowPos(Me.hwnd, -1, 0, 0, 0, 0, 3)
End Sub


Private Sub modiuserinfo_Click()
W1.SendData "usif" & Locateuser
Modinfo.Show
End Sub

Private Sub NewAdd_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
If Len(Selectuser) = 0 Then Exit Sub
tweworld.Caption = "与" & Selectuser & "进入二人世界(&T)"
DelUser.Caption = "将" & Selectuser & "从该组删除"
SSound.Caption = "发语音消息给" & Selectuser
PopupMenu usermenu, vbPopupMenuLeftAlign, 4500
End If
End Sub

Private Sub NewAdd_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If NewAdd(Index).ListCount = 0 Then Selectuser = "": Exit Sub
Dim pos As Long, idx As Long
    pos = X / Screen.TwipsPerPixelX + Y / Screen.TwipsPerPixelY * 65536
    idx = SendMessage(NewAdd(Index).hwnd, LB_ITEMFROMPOINT, 0, ByVal pos)
     If idx < 65536 Then
     For a = 0 To NewAdd(Index).ListCount - 1
     If NewAdd(Index).List(a) = NewAdd(Index).List(idx) Then
     NewAdd(Index).Selected(a) = True
     If Button = 0 Then
     Selectuser = NewAdd(Index).List(a)
     End If
     Exit Sub
     End If
     Next
     End If
End Sub

Private Sub NewCommand_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
t1.SetFocus
If Button = vbRightButton Then
PopupMenu Group, vbPopupMenuLeftAlign, 4500
End If
End Sub

Private Sub NewRt_Click()
t1.SetFocus
RunRun = 0
NewRt.Visible = False
BlackVisual False
AllNewVisual False
L1.Visible = True
L1.ZOrder 0
Command4.Visible = True
Command2.Visible = True
Command2.ZOrder 0
kc = True
Command2_MouseDown vbLeftButton, 0, 0, 0
L1.ZOrder 0
Command4.ZOrder 0
Command7.ZOrder 0
ht.ZOrder 0
t1.ZOrder 0
End Sub

Private Sub P1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
 If Hex(X) = "1E0F" Then
 If W1.State <> 7 Then
 Command1.Caption = "连接(&R)"
 Command1_Click
 Exit Sub
 End If
 Me.Visible = True
 Me.ZOrder 0
     SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
     SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 3
Exit Sub
End If
If Hex(X) = "1E3C" Then
PopupMenu SysM, vbPopupMenuLeftAlign
End If
End Sub

Private Sub rt_Click()
bd.Visible = False
rt.Visible = False
black.Left = L1.Left
black.Visible = False
End Sub

Private Sub setoff_Click()
If Ifsound = True Then Ifsound = False: setoff.Caption = "开启音效" Else Ifsound = True: setoff.Caption = "禁止音效"
End Sub

Private Sub Sf_Close(Index As Integer)
Sf(0).Close
Sf(0).LocalPort = 0
Sf(0).RemotePort = 0
End Sub

Private Sub Sf_ConnectionRequest(Index As Integer, ByVal requestID As Long)
If ifhb = True Then
wb.Show
wb.hb.Accept requestID
Exit Sub
End If
End Sub

Private Sub Sfile_Click()
SoundSend = False
SeleFile = SeleFileBox
If SeleFile = "" Then Exit Sub
If Dir(SeleFile, vbNormal) = "" Then MsgBox "对不起,此文件不存在", vbInformation + vbOKOnly, "提示": Exit Sub
   If MsgBox("你想把文件传给" & Selectuser & "吗？" & Endchr & "→" & SeleFile, vbYesNo + vbInformation, "确认") = vbYes Then
      Load Form2
      Chang 4, "传送文件"
   End If
End Sub

Private Sub SSound_Click()
Load Wave
End Sub

Private Sub t1_DblClick()
t1.Text = Trim(t1.Text) + love
End Sub

Private Sub t1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyF5 Then   'Return And (Shift And vbCtrlMask) > 0 Then
Call Sendclick
t1.Text = ""
End If
End Sub

Private Sub t2_Click()
Select Case t2.ListIndex
Case 0
t2.ForeColor = ht.SelColor
t2.BackColor = ht.BackColor
Case 1
t2.BackColor = t1.BackColor
t2.ForeColor = t1.ForeColor
Case 2
t2.BackColor = L1.BackColor
t2.ForeColor = L1.ForeColor
End Select
t1.SetFocus
End Sub

Private Sub tbor_Click()
On Error GoTo Err01
wb.Show
wb.Caption = "与" & Selectuser & "在二人画板"
Dim Commag As String
Commag = "fbfb" & Selectuser & "~" & Locateuser & "~" & W1.LocalIP
W1.SendData Commag
ifhb = True
If Sf(0).State <> sckListening Then
wb.hb.LocalPort = 0
With Sf(0)
.LocalPort = 6666 - 1
.RemotePort = 0
.Listen           '当客户机发送完请求后，继续侦听
End With
End If
Exit Sub
Err01:
If Err.Number = 10048 Then
With Sf(0)
.LocalPort = 6666 - 2
.RemotePort = 0
.Listen
End With
End If
Resume Next
End Sub

Private Function VisualMB(Index As Integer, go As String) As Integer
For a = 1 To NowGroup               '将目标可见
If ExistGroup(a) = True Then
If Trim(NewCommand(a).Caption) = go Then
NewCommand(a).ZOrder 0
NewCommand(a).Visible = True
NewAdd(a).ZOrder 0
NewAdd(a).Visible = True
NewRt.ZOrder 0
NewRt.Visible = True
Command7.ZOrder 0
Exit For
End If
End If
Next
VisualMB = a
End Function

Private Sub Addtogroup_Click(Index As Integer)
Dim go As String
Dim b As Integer
Dim Exist As Boolean
Exist = False
a = VisualMB(Index, Trim(Mid(AddtoGroup(Index).Caption, 3)))
For b = 0 To NewAdd(a).ListCount
If Trim(NewAdd(a).List(b)) = Selectuser Then Exist = True
If NewAdd(a).ListCount = 0 Then Exit For
Next

If Exist = True Then Exit Sub
For b = 1 To L1.ListCount
If L1.List(b - 1) = Selectuser Then
L1.RemoveItem b - 1
NewAdd(a).AddItem Selectuser
Exit For
End If
Next
DelUser.Visible = True
ht.ZOrder 0
t1.ZOrder 0
End Sub

Private Sub Timer1_Timer()
If W1.State = 7 Then W1.SendData "YIai" & Locateuser 'Yes I am it
End Sub

Private Sub tweworld_Click()
On Error Resume Next
If p2p = True Then
ht.SaveFile Selectuser & ".msg", rtfRTF
ht.Text = ""
If FileLen("client.msg") > 0 Then ht.LoadFile "Client.msg", rtfRTF
p2p = False                     '在校园及时通
Me.Caption = Locateuser & "在校园及时通 "
If L1.Enabled = False Then L1.Enabled = True
tweworld.Caption = "二人世界"
Command2.Caption = "我的邻居"
Else
p2p = True           '在二人世界
ht.SaveFile "Client.msg", rtfRTF
ht.Text = ""
If FileLen(Selectuser & ".msg") > 0 Then ht.LoadFile Selectuser & ".msg", rtfRTF
L1.Enabled = False
Me.Caption = Locateuser & "与" & Selectuser & "在二人世界"
Command2.Caption = "我的同事"
tweworld.Caption = "校园及时通"
Chang 2, Me.Caption
 End If
End Sub

Private Sub undo_Click()
black.RemoveItem (a)
L1.AddItem Selectuser
rt_Click
End Sub

Private Sub W1_close()
SockCloseError
End Sub

Private Sub W1_Connect()
Command1.Caption = "发送(&S)"
W1.SendData "myna" & Locateuser & "~" & Passwords
  With t
    .cbSize = Len(t)
    .hwnd = P1(0).hwnd
    .uId = 1&
    .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    .ucallbackMessage = WM_MOUSEMOVE
    .hIcon = P1(0).Picture
    .szTip = "校园及时通-" & Locateuser & Chr$(0)
  End With
    Shell_NotifyIcon NIM_ADD, t
    bCancel = False
   If ifNM = True Then
    Group.Enabled = False
     tweworld.Enabled = False
      Sfile.Enabled = False
       SSound.Enabled = False
        LastSound.Enabled = False
       lysend.Enabled = False
      bl.Enabled = False
     usermenu.Enabled = False
    modiuserinfo.Enabled = False
   End If
   INIgroup
    RegisterHotKey Me.hwnd, &HBFFF&, MOD_CONTROL, vbKeyLeft
    ProcessMessages
End Sub

Private Sub ProcessMessages()
    Dim Message As Msg
    Do While Not bCancel
        WaitMessage
        If PeekMessage(Message, Form1.hwnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
If Me.Height < 1000 Then
Command2_MouseDown vbLeftButton, 0, 0, 0
Else
Call mini_Click
End If
End If
        DoEvents
    Loop
End Sub
Private Sub SockCloseError()
If Command1.Caption = "连接(&R)" Then Exit Sub
Command1.Caption = "连接(&R)"
End Sub

Private Sub W1_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim Mag As String
Dim b As Integer, C As Integer
Dim Requestuser As String
   Dim Filename As String
   Dim IPadd As String
   Dim Fileleg As String
W1.GetData Mag
Select Case Left(Mag, 4)

'Case "on??"   '用于服务器自动侦探用户是否掉线,用Timer来代替
'W1.SendData "YIai" & Locateuser 'Yes I am it
'Exit Sub

Case "jjjj"
'"jjjj" & Suser & "~S" & W1.LocalIP    "jjjj" & Suser & "~" & W1.LocalIP
Form2.s.Close
If Mid(Mag, InStr(5, Mag, "~") + 1, 1) = "S" Then
Form2.s.Connect Mid(Mag, 7)
Else
Form2.s.Connect Mid(Mag, 6)
End If
Exit Sub

Case "mook"   '个人资料修改成功
MsgBox "资料已成功修改", vbOKOnly + vbSystemModal + vbInformation
Exit Sub

Case "usif"  '用户资料
Dim mname As String, msex As String, moffice As String, mpassword As String
'"usif" & Trim(rc(0).Value) & "~" & Trim(rc(1).Value) & "~" & Trim(rc(2).Value) & "~" & Trim(rc(5).Value)
a = InStr(5, Mag, "~")
b = InStr(a + 1, Mag, "~")
C = InStr(b + 1, Mag, "~")
mname = Mid(Mag, 5, a - 5)
msex = Mid(Mag, a + 1, b - a - 1)
moffice = Mid(Mag, b + 1, C - b - 1)
mpassword = Mid(Mag, C + 1)
With Modinfo
.fields(0) = mname
.sexmw = msex
.fields(1) = moffice
If mname = Locateuser Then .fields(2) = mpassword: .Cmdok.Enabled = True Else .fields(2) = "不要看别人的密码": .Cmdok.Enabled = False
End With
Exit Sub

Case "SYSM"
MsgBox Mid(Mag, 5), vbOKOnly + vbSystemModal, "提示"
Exit Sub

Case "info"   '看留言
If Mid(Mag, 5, 1) = "1" Then
Me.Visible = True
  If Len(Mag) > 5 Then
   lymag = Mid(Mag, 6): Beep
     If MsgBox("有你的留言,是否想看呢?", vbQuestion + vbSystemModal + vbYesNo, "提示") = vbYes Then
      MsgBox lymag, , "你的留言"
      Exit Sub
     End If
   End If