server.frm

校园及时通,很好的通信软件！

If Button = 2 Then
PopupMenu q, vbPopupMenuLeftAlign
End If
End Sub

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

Private Sub Reco_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then PopupMenu l, vbPopupMenuLeftAlign
End Sub

Private Sub reset_Click()
On Error Resume Next
listen.Close
Text1.SetFocus
For a = 1 To Connected
Unload connect1(Connected)
Next
Call Form_Load
End Sub

Private Sub Seeip_Click()
   For a = 0 To online.ListCount - 1
     If online.Selected(a) = True Then
     online.Selected(a) = True
     MsgBox online.list(a) & "的IP地址是:" & connect1(online.ItemData(a)).RemoteHostIP
     End If
     Next
End Sub

Private Sub Send_IP_Timer()
Dim f1 As Integer, f2 As Integer, f3 As Integer
Dim NewAdd As String
f2 = InStr(Len(listen.LocalIP) - 3, listen.LocalIP, ".")
gofind:
    f1 = InStr(f2, listen.LocalIP, ".")
     f3 = InStr(f1 + 1, listen.LocalIP, ".")
       If f3 <> 0 Then f2 = f3: GoTo gofind Else f1 = f2
         NewAdd = Left(listen.LocalIP, f1 - 1) & "." & CStr(255)
With Sock_IP
.Close
.RemoteHost = NewAdd
.RemotePort = 2019
.SendData listen.LocalIP
End With
End Sub

Private Sub Sock_IP_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
Sock_IP.Close
End Sub

Private Sub Tc_Click()
  For a = 0 To online.ListCount - 1
     If online.Selected(a) = True Then
     online.Selected(a) = True
     If connect1(online.ItemData(a)).State = 7 Then
     connect1(online.ItemData(a)).SendData "SYSM系统管理员将你清除出用户群"
     DoEvents
     Unb = online.ItemData(a)
     Onlineuser = Onlineuser - 1
     MsgBox "此用户已掉线", vbOKOnly, "提示"
     End If
     online.RemoveItem (a)
     Exit Sub
     End If
     Next
End Sub


Private Sub smag_Click()
 Text1.SetFocus
 If Len(Text1.Text) < 1 Or Onlineuser = 0 Then Exit Sub
   Commandf = 1
     Sendmag = "系统广播:" & Text1.Text
        Text1.Text = ""
        Call Exec
End Sub

Private Sub SYSETc_Click()
On Error Resume Next
Text1.SetFocus
If online.Height < 1000 Then
For a = 450 To Me.Height Step 130
SYSETc.Top = a - 750
online.Height = a - 490
DoEvents
Next
SYSETc.Caption = "系统设置"
SYSETc.Top = Me.Height - SYSETc.Height - 280
online.Height = Me.Height - 300
Else
For a = online.Height To 0 Step -130
SYSETc.Top = a - 150
online.Height = a + 40
DoEvents
Next
SYSETc.Caption = "保存返回"
online.Height = 0
SYSETc.Top = 0
End If
End Sub

Private Sub t1_Click()
Select Case t1.ListIndex
Case 0
t1.ForeColor = Reco.SelColor
t1.BackColor = Server.Reco.BackColor
Case 1
Command2.Enabled = True
t1.BackColor = Server.Text1.BackColor
t1.ForeColor = Server.Text1.ForeColor
Case 2
Command2.Enabled = True
t1.BackColor = Server.online.BackColor
t1.ForeColor = Server.online.ForeColor
End Select
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
 If KeyAscii = Asc(vbCr) Then
   Text1.SetFocus
     Call smag_Click
    KeyAscii = 0
 End If
End Sub

'Private Sub chang()
'Static I As Long
'With t
'    .cbSize = Len(t)
'    .hwnd = Picture1(0).hwnd
'    .uId = 1&
'    .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
'    .ucallbackMessage = WM_MOUSEMOVE
'    .szTip = "校园及时通(School NC Server)→罗明,在线人数" & Onlineuser & Chr$(0)
'    .hIcon = Picture1(I).Picture
'End With
'Shell_NotifyIcon NIM_MODIFY, t
'    I = I + 1
'    If I = 4 Then I = 0
'End Sub

Private Sub Exec()
Dim b As Integer, c As Integer, d As Integer
On Error Resume Next
'Call chang
Select Case Commandf
Case 1
  For a = 1 To Connected  '有错
    If connect1(a).State = 7 Then
           connect1(a).SendData Sendmag
            DoEvents
    End If
  Next
  Reco.Text = Sendmag & Endchr & Reco.Text
  Exit Sub
    
Case 2
     connect1(QuserSocknumber(fname)).SendData Sendmag
       DoEvents
      If C2.Value <> 0 And sf = False Then Reco.Text = Sendmag & Endchr & Reco.Text     '显示二人世界聊天记录
          sf = False
             
Case 3
 'Commag = "fbfb" & Selectuser & "~" & Locateuser & "~" & W1.LocalIP
   connect1(QuserSocknumber(fname)).SendData "mwhi" & Sendmag   '向目标机发送请求
     DoEvents
     Exit Sub
Case 4
'  "123~abc~plo~~~" & Locateuser & "说:  (" & Chr(10) & t1.Text
 Dim SendGroupMm As String, Fuser As String
 a = InStr(1, Sendmag, "~~~")
 c = InStr(1, Sendmag, "~")
 SendGroupMm = Mid(Sendmag, a + 3)    '提出发送消息
 Fuser = Mid(Sendmag, 1, c - 1)     '提出第一个用户
 SendGroupMag CStr(SendGroupMm), Fuser     '调用子程序发送消息
  For b = 1 To a
    d = InStr(c + 1, Sendmag, "~")
      If InStr(c + 1, Sendmag, "~~~") = 0 Then Exit Sub
      If d = 0 Then
       Fuser = Right(Sendmag, Len(Sendmag) - c - 1)  '提出最后一个用户
       SendGroupMag CStr(SendGroupMm), Fuser
      Exit Sub
      End If
       Fuser = Mid(Sendmag, c + 1, d - c - 1)
       If Fuser = "" Then Exit Sub
       SendGroupMag CStr(SendGroupMm), Fuser
       c = d
  Next
Exit Sub

 Case 5
  Timer1.Enabled = True
 Exit Sub

 Case 6
     connect1(QuserSocknumber(fname)).SendData "nono"    '向目标机发送请求
       DoEvents
 Exit Sub

Case 7   '响应客户向某客户发送Msgbox消息
   Dim Cf As String
   Select Case Left(Sendmag, 1)
      Case "M"
      Cf = "MMMM"
      Case "C"
      Cf = "CCCC"
      Case "W"
      Cf = "WWWW"
      End Select
      connect1(QuserSocknumber(fname)).SendData Cf & Mid(Sendmag, 2)   '向目标机发送请求
      Exit Sub
End Select
End Sub
Private Sub picture1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Hex(X) = "1E3C" Then
        If Me.Visible = False Then up.Caption = "前台运行" Else up.Caption = "后台运行"
        PopupMenu see, vbPopupMenuLeftAlign
    End If
End Sub

Private Sub listen_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)
Beep
MsgBox "侦听错误-->" & Description, vbOKOnly, "连接错误"
End Sub

Private Sub connect1_Error(Index As Integer, 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)
On Error Resume Next
For a = 1 To 5
Beep
Next
connect1(Index).Close
Unload connect1(Index)
For a = 1 To online.ListCount
If online.ItemData(a - 1) = Index Then
Unload connect1(online.ItemData(a - 1))
'MsgBox online.list(a) & "联接错误-->" & Description
online.RemoveItem (a - 1)   '在线用户列表上删除
Onlineuser = Onlineuser - 1  '在线人数减一
sb(1).Caption = Onlineuser   '显示状态
Commandf = 5
Call Exec
Exit Sub
End If
Next
End Sub
Private Function Onli()
Dim SendName As String
On Error Resume Next
Onli = ""
For a = 0 To online.ListCount - 1
SendName = SendName & "~" & online.list(a)
Next
Onli = SendName
End Function

Private Sub Timer1_Timer()
On Error Resume Next
Dim num As String, Listcon As String
Timer1.Enabled = False
  Listcon = online.ListCount
  num = Onli()
  For a = 1 To Connected
       If connect1(a).State = 7 Then
         connect1(a).SendData "onli" & Listcon & num  '调用onli函数返回在线名单
         DoEvents
       End If
  Next
End Sub

Private Sub Timer2_Timer()
On Error Resume Next
'For a = 1 To Connected
' If connect1(a).State = 7 Then
  'connect1(a).SendData "on??"
  'DoEvents
 'End If
'Next
rc.MoveFirst
Do Until rc.EOF
rc.Edit
rc(6).Value = False
rc.Update
DoEvents
rc.MoveNext
DoEvents
Loop
Timer3.Enabled = True
End Sub

Private Sub Timer3_Timer()
On Error Resume Next
Dim Delsock As Integer
rc.MoveFirst
Do Until Not rc.EOF
If rc(6).Value = False Then
Delsock = QuserSocknumber(rc(0).Value)
If Delsock <> 0 Then
connect1(Delsock).Close
Unload connect1(Delsock)
online.RemoveItem CInt(online.Tag)
Commandf = 5
Call Exec
Timer3.Enabled = False
Exit Sub
End If
End If
rc.MoveNext
DoEvents
Loop
Timer3.Enabled = False
End Sub
Private Function QuserSocknumber(name As String) As Integer
QuserSocknumber = 0
Dim Runnum As Integer
For Runnum = 0 To online.ListCount - 1
If name = online.list(Runnum) Then
QuserSocknumber = online.ItemData(Runnum)
online.Tag = Runnum
Exit Function
End If
DoEvents
Next
End Function

Public Sub ProMag()
On Error Resume Next
If Me.Visible = False Then
Me.Visible = True
SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3
SetWindowPos Me.hwnd, -2, 0, 0, 0, 0, 3
RegisterServiceProcess GetCurrentProcessId, 0
Exit Sub
Else
Me.Visible = False
Call SetWindowPos(Me.hwnd, -2, 0, 0, 0, 0, 3)
RegisterServiceProcess GetCurrentProcessId, 1
End If
End Sub

Private Sub up_Click()
Call ProMag
End Sub

Private Function ExitProgram() As Boolean
Dim OldP As String, NewP As String
ExitProgram = False
OldP = Trim(InputBox("请输入退出密码", "退出"))
If Trim(getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "ExitP")) <> OldP Then
MsgBox "输入密码错误", vbOKOnly + vbSystemModal, "非法管理员"
ExitProgram = True
Exit Function
Else

If Not C1.Value = 0 Then
Call savestring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\run", "Net Call Server", SavePath & App.EXEName & ".exe")
Else
Call DeleteValue(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\run", "Net Call Server")
End If

If C2.Visible = 0 Then allow = False Else allow = True

Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "AutoSense", CStr(C4.Value))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "AllowRead", CStr(C2.Value))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "RunMode", CStr(C3.Value))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "TalkRecoForeColor", CStr(Reco.SelColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "TalkRecoBackColor", CStr(Reco.BackColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "SendMagsageBackColor", CStr(Text1.BackColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "SendMagsageForeColor", CStr(Text1.ForeColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "OnlinenameBackColor", CStr(online.BackColor))
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "OnlinenameForeColor", CStr(online.ForeColor))
    rc.Close
    rs.Close
    rw.Close
 Dim ret As Long
 ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)   '取消Message的截取，而使之又只送往原来的Window Procedure
 Call UnregisterHotKey(Me.hwnd, uVirtKey)
'    With t
'    .cbSize = Len(t)
'    .hwnd = Picture1(0).hwnd
'    .uId = 1&
'    End With
'    Shell_NotifyIcon NIM_DELETE, t
End
ExitProgram = False
End If
End Function

Private Sub SendGroupMag(Mag As String, SendName As String)
  For a = 0 To online.ListCount - 1
     If online.list(a) = SendName Then
        connect1(online.ItemData(a)).SendData Mag   '要加一个前缀
        DoEvents
        Exit Sub
     End If
    Next
End Sub
Private Function Quserinfo(name As String) As String  '查寻用户资料
Dim sex As String
Quserinfo = ""
If rc.RecordCount = 0 Then Exit Function
rc.FindFirst rc(0).name & " = '" & name & "'"
If Not rc.NoMatch Then
If rc(1).Value = True Then sex = "男" Else sex = "女"
Quserinfo = Trim(rc(0).Value) & "~" & sex & "~" & Trim(rc(2).Value) & "~" & Trim(rc(5).Value)
End If
End Function

Private Function Qpassword(name As String) As String  '查寻密码
If rc.RecordCount = 0 Then Exit Function
rc.FindFirst rc(0).name & " = '" & name & "'"
If Not rc.NoMatch Then Qpassword = Trim(rc(5).Value)
End Function

Private Function Ifhadmag(name As String) As String  '查寻是否有留言,如有就发关
Ifhadmag = ""
If rc.RecordCount = 0 Then Exit Function
rc.MoveFirst
For a = 1 To rc.RecordCount
If name = rc(0).Value Then
If rc(3).Value = True Then
Ifhadmag = Trim(rc(4).Value)
rc.Edit
rc(3).Value = False
rc.Update
Exit Function
End If
End If
Next
End Function