server.frm

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

Private Sub c2_Click()
If Me.Visible = True Then Text1.SetFocus
End Sub

Private Sub C3_Click()
If Me.Visible = True Then Text1.SetFocus
End Sub

Private Sub C4_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Me.Visible = True Then Text1.SetFocus
If C4.Value = 0 Then
   Timer2.Enabled = False
 Else
   If MsgBox("本功能的作用是由服务器自动侦测用户是否意外掉线" & Chr(13) & Chr(10) & "但某二个用户在传送大文件时,此选项可能会导致用户传送文件失败,是否选定?", vbYesNo + vbQuestion + vbSystemModal, "注意") = vbNo Then C4.Value = 0: Exit Sub
  Timer2.Enabled = True
 End If
End Sub

Private Sub clearreco_Click()
Reco.Text = ""
Text1.SetFocus
End Sub

Private Sub Command1_Click()
Text1.SetFocus
Call Colorset
If rtn >= 1 Then
   Select Case t1.ListIndex
 Case 0
   t1.BackColor = cc.rgbResult
   Server.Reco.BackColor = cc.rgbResult
 Case 1
   t1.BackColor = cc.rgbResult
   Server.Text1.BackColor = cc.rgbResult
 Case 2
   t1.BackColor = cc.rgbResult
   Server.online.BackColor = cc.rgbResult
End Select
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 Command2_Click()
Call Colorset
If rtn >= 1 Then
Select Case t1.ListIndex
 Case 0
   t1.ForeColor = cc.rgbResult
   Reco.SelColor = cc.rgbResult
 Case 1
   t1.ForeColor = cc.rgbResult
   Text1.ForeColor = cc.rgbResult
 Case 2
   t1.ForeColor = cc.rgbResult
   online.ForeColor = cc.rgbResult
End Select
End If
Text1.SetFocus
End Sub

Private Sub Command3_Click()
Readme.Show
End Sub

Private Sub Command4_Click()
Dim OldP As String, NewP As String
Text1.SetFocus
OldP = Trim(InputBox("请输入旧密码", "系统重要提示"))
If Trim(getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "ExitP")) <> OldP Then MsgBox "输入密码错误", vbOKOnly + vbSystemModal, "非法管理员": Exit Sub
Agein2:
NewP = Trim(InputBox("请输入新密码", "系统重要提示"))
OldP = Trim(InputBox("请再一次输入新密码,以确认", "系统重要确认"))
If NewP <> OldP Then
If MsgBox("前一次与后一次密码不一致,是否重来一次", vbYesNo) = vbYes Then GoTo Agein2 Else Exit Sub
Else
Call savestring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "ExitP", NewP)
Beep
MsgBox "系统管理员密码成功修改", vbOKOnly
End If
End Sub

Private Sub Command5_Click()
Dim OldP As String, NewP As String
OldP = Trim(InputBox("请输入管理员密码", "提示"))
If Trim(getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "ExitP")) <> OldP Then
MsgBox "输入密码错误", vbOKOnly + vbSystemModal, "非法管理员"
Else
add.Show
End If
Text1.SetFocus
End Sub

Private Sub connect1_SendComplete(Index As Integer)
sb(3).Caption = "已给" & CStr(Index) & "发送"
If Unb = Index Then
Unload connect1(Index)
Unb = 0
End If
End Sub

Private Sub endserver_Click()
ExitProgram
End Sub

Private Sub Form_Load()
On Error Resume Next
If App.PrevInstance Then End
 '以下语句用于打开DAO
    '创建工作区
    If Dir(SavePath & "User.mdb", vbNormal) <> "" Then
    Set rw = CreateWorkspace("", "admin", "")
    '打开数据库
    Set rs = rw.OpenDatabase(SavePath & "User.mdb")
    '创建结果集（以下两语句功能一样）
    'Set rc = rs.OpenRecordset("userinfo", dbOpenDynaset)
    Set rc = rs.OpenRecordset("select * from userinfo")
Else
MsgBox "没找到用户数据库,请奶出并重建", vbExclamation + vbOKOnly + vbSystemModal, "严重错误"
End
End If
Getwin True
Endchr = Chr(13) & Chr(10) & Chr(13) & Chr(10)
Me.Caption = "校园及时通服务器  本地IP→" & listen.LocalIP
Reco.SelColor = QBColor(13)      '洋红色
allow = False
Onlineuser = 0
Connected = 0
RegisterServiceProcess GetCurrentProcessId, 1
'If getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "RunMode") = 0 Then Me.Visible = True: RegisterServiceProcess GetCurrentProcessId, 0
If Not getstring(HKEY_LOCAL_MACHINE, "Software\New Sun\Net Call Server", "TalkRecoBackColor") = 0 Then
Reco.SelColor = getstring(HKEY_LOCAL_MACHINE, "Software\New Sun\Net Call Server", "TalkRecoForeColor")
Reco.BackColor = getstring(HKEY_LOCAL_MACHINE, "Software\New Sun\Net Call Server", "TalkRecoBackColor")
Text1.BackColor = getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "SendMagsageBackColor")
Text1.ForeColor = getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "SendMagsageForeColor")
online.BackColor = getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "OnlinenameBackColor")
online.ForeColor = getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "OnlinenameForeColor")
C4.Value = getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "AutoSense")
If C4.Value = 0 Then Timer2.Enabled = False
End If
t1.ListIndex = 0
C2.Value = getstring(HKEY_LOCAL_MACHINE, "Software\New Sun\Net Call Server", "AllowRead")
If Len(getstring(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\run", "Net Call Server")) > 3 Then C1.Value = 1 Else C1.Value = 0
If Not getstring(HKEY_LOCAL_MACHINE, "software\New Sun\Net Call Server", "RunMode") = 0 Then C3.Value = 1
If getstring(HKEY_LOCAL_MACHINE, "Software\New Sun\Net Call Server", "AllowRead") Then allow = True
If Len(Dir(SavePath & "server.msg")) <> 0 Then Reco.LoadFile SavePath & "server.msg", rtfRTF
'With t
'    .cbSize = Len(t)
'    .hwnd = Picture1(0).hwnd
'    .uId = 1&
'    .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
'    .ucallbackMessage = WM_MOUSEMOVE
'    .hIcon = Picture1(0).Picture
'    .szTip = "校园及时通(School NC Server)→罗明" & Chr$(0)
'End With
'Shell_NotifyIcon NIM_ADD, t

With Sock_IP
.Protocol = sckUDPProtocol
.RemoteHost = "100.222.222.222"
.RemotePort = 1002
.Bind
End With

online.Clear
listen.LocalPort = 7777
listen.listen

Dim ret As Long
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
SetWindowLong Me.hwnd, GWL_WNDPROC, AddressOf wndproc
  bCancel = False
 'in the range &h0000 through &hBFFF
  ret = RegisterHotKey(Me.hwnd, &HBFFF&, MOD_CONTROL, vbKeyF12)
 ProcessMessages
End Sub
  
Private Sub connect1_Close(Index As Integer)
On Error Resume Next
If online.ListCount = 0 Then sb(3).Caption = "无人在线": Exit Sub
For a = 1 To online.ListCount
If online.ItemData(a - 1) = Index Then
Unload connect1(online.ItemData(a - 1))
online.RemoveItem (a - 1)   '在线用户列表上删除
Onlineuser = Onlineuser - 1  '在线人数减一
sb(1).Caption = Onlineuser   '显示状态
Commandf = 5
Call Exec
Exit Sub
End If
Next
End Sub

Private Sub connect1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
Dim Mag As String, a As Integer, b As Integer, c As Integer
connect1(Index).GetData Mag
Select Case Left(Mag, 4)

Case "YIai"
 fname = Mid(Mag, 5)
  rc.MoveFirst
    rc.Edit
     Do Until rc.EOF
      If fname = rc(0).Value Then
        rc(6).Value = True
       rc.Update
       Exit Sub
      End If
     rc.MoveNext
     DoEvents
     Loop
 
 '"jjjj" & Suser & "~" & W1.LocalIP
 Case "jjjj"
 fname = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
 For b = 0 To online.ListCount - 1
    If online.list(b) = fname Then
       connect1(online.ItemData(b)).SendData "jjjj" & Mid(Mag, InStr(5, Mag, "~"))
         DoEvents
           Exit Sub
    End If
 Next
 Exit Sub
 Case "lyma"
 '"lyma" & Selectuser & "~" & Locateuser & "留言:" & lymag
 a = InStr(5, Mag, "~")
 fname = Mid(Mag, 5, a - 5)
 With rc
 rc.FindFirst rc(0).name & " = '" & fname & "'"
 If Not .NoMatch Then
        .Edit
        rc(3) = 1
        rc(4) = Mid(Mag, a + 1)
 .Update
 End If
 End With
 
 Case "moov"
 'fields(0) & "~" & sexmw & "~" & fields(1) & "~" & fields(2) & "~" & Form1.Locateuser
 Dim mname As String, msex As Boolean, moffice As String, mpassword As String
 a = InStr(5, Mag, "~")
 b = InStr(a + 1, Mag, "~")
mname = Mid(Mag, 5, a - 5)
If Mid(Mag, a + 1, b - a - 1) = "男" Then msex = 1 Else msex = 0
c = InStr(b + 1, Mag, "~")
a = InStr(c + 1, Mag, "~")
moffice = Mid(Mag, b + 1, c - b - 1)
mpassword = Mid(Mag, c + 1, a - c - 1)
fname = Mid(Mag, a + 1)
rc.FindFirst rc(0).name & " = '" & fname & "'"
 If Not rc.NoMatch Then
        rc.Edit
        rc(0).Value = mname '姓名
        rc(1) = msex  '性别
        rc(5).Value = mpassword '密码
        rc(2).Value = moffice '职务
    rc.Update
 End If
connect1(Index).SendData "mook": DoEvents
 For a = 0 To online.ListCount - 1
 If online.list(a) = fname Then online.list(a) = mname: Exit Sub
 Next
 
 Case "usif"
'W1.SendData "usif" & Locateuser
fname = Mid(Mag, 5)
connect1(Index).SendData "usif" & Quserinfo(fname)
DoEvents
            
 Case "myna"                                '在有人上线时发生
            Dim Rname As String, Password As String, lymag As String
            a = InStr(5, Mag, "~")
            Rname = Mid(Mag, 5, a - 5)
            Password = Mid(Mag, a + 1)
       If Mid(Rname, 1, 2) <> "过客" Then
          For a = 0 To online.ListCount - 1
            If online.list(a) = Rname Then
              connect1(Index).SendData "info2已有人用该ID登录,请换一个用户名"
                DoEvents
               Unb = Index
               Exit Sub
            End If
          Next

            If Password <> Qpassword(Rname) Then
              connect1(Index).SendData "info2你使用的密码有误,请重试"
               DoEvents
               Unb = Index
              Exit Sub
            End If
       lymag = Ifhadmag(Rname) '查寻是否有留言,有否发送
       End If
     rc.MoveFirst
      Do Until rc.EOF
        rc.FindFirst rc(0).name & " = '" & Rname & "'"
          If rc.NoMatch = False Then
            rc.Edit
              rc(6).Value = 1
            Server.rc.Update
          Exit Do
        End If
      DoEvents
      rc.MoveNext
      Loop
       connect1(Index).SendData "info1" & lymag
       DoEvents
       online.AddItem Rname       '在列表上添加用户名
       online.ItemData(Onlineuser) = Index            '在列表数据上添加winsokc(index)
       Onlineuser = Onlineuser + 1                   '有人上线
       sb(1).Caption = Onlineuser
       Commandf = 5  'onli
Call Exec
   Exit Sub
   
   Case "onli"                                '客户登录时发送 onli 查寻用户数和所有用户名
connect1(Index).SendData "onli" & online.ListCount & Onli()  '调用onli函数返回在线名单
   DoEvents
   Case "p2p2"
      Commandf = 2
       fname = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
       Sendmag = Right(Mag, Len(Mag) - InStr(5, Mag, "~"))
         Call Exec
   
   Case "allw"
     Commandf = 1
       Sendmag = Right(Mag, Len(Mag) - 4)
         Call Exec
   
   Case "MMMM"
 Commandf = 7
fname = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
Sendmag = Left(Mag, 1) & Mid(Mag, InStr(5, Mag, "~") + 1, Len(Mag) - InStr(5, Mag, "~"))
'Selectuser & "~" & Right(t1.Text, Len(t1.Text) - 4)
Call Exec

  
  Case "WWWW"
 Commandf = 7
fname = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
Sendmag = Left(Mag, 1) & Mid(Mag, InStr(5, Mag, "~") + 1, Len(Mag) - InStr(5, Mag, "~"))
'Selectuser & "~" & Right(t1.Text, Len(t1.Text) - 4)
Call Exec

 Case "CCCC"
Commandf = 7
fname = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
Sendmag = Left(Mag, 1) & Mid(Mag, InStr(5, Mag, "~") + 1, Len(Mag) - InStr(5, Mag, "~"))
'Selectuser & "~" & Right(t1.Text, Len(t1.Text) - 4)
Call Exec
  'Commag = "fbfb" & Selectuser & "~" & Locateuser & "~" & W1.LocalIP
  Case "fbfb"
   ' "fbfb" & Selectuser & "~" & Locateuser & "~" & W1.LocalIP
   Commandf = 3   '建立画板
   fname = Mid(Mag, 5, InStr(5, Mag, "~") - 5)
     Sendmag = Right(Mag, Len(Mag) - InStr(5, Mag, "~"))
      Call Exec
    
    Case "nono"
    ' "nono" & name1
    fname = Mid(Mag, 5)
   Commandf = 6
    Call Exec
    Exit Sub
 
 Case "sfil"
'Locateuser & "~" & Selectuser & "~" & Selefile & "~" & FileLen(Form1.Selefile) & "~" & W1.LocalIP & "F"
   Dim Requestuser As String
   Dim Selectuser1 As String
   Dim Filename As String
   Dim Ipadd As String
   Dim Fileleg, s, t, ff As Integer
   a = InStr(5, Mag, "~")
   s = InStr(a + 1, Mag, "~")
   t = InStr(s + 1, Mag, "~")
   ff = InStr(t + 1, Mag, "~")
   Requestuser = Mid(Mag, 5, a - 5)
   Selectuser1 = Mid(Mag, a + 1, s - a - 1)
   Filename = Mid(Mag, s + 1, t - s - 1)
   Fileleg = Mid(Mag, t + 1, ff - t - 1)
      Commandf = 2
      Ipadd = Mid(Mag, ff + 1, Len(Mag) - ff - 1)
  fname = Selectuser1
If Right(Mag, 1) = "F" Then
   Sendmag = "reqf" & Requestuser & "~" & "请求向你传送文件:" & Filename & ",长度为:" & Fileleg & "~" & Ipadd
   sf = True
Else
   Sendmag = "reqS" & Requestuser & "~" & "请求向你传送语音消息,长度为" & Fileleg & "~" & Ipadd
End If
   Call Exec
   Exit Sub
Case "grou"
'f = "grou~123~abc~plo~~~" & Locateuser & "说:  (" & Chr(10) & t1.Text
Commandf = 4
Sendmag = Mid(Mag, 6)
   Call Exec
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Ifexit = True
Cancel = ExitProgram
End Sub

Private Sub I1_Click()
I1.Visible = False
I2.Left = I1.Left
I2.Visible = True
Me.Height = 4300
Text1.Height = 1425
online.Height = 3840 ' Me.Height - SYSETc.Height - 400
SYSETc.Top = 3755
For a = 0 To 3
sb(a).Top = 3950 - sb(0).Height
Next
End Sub

Private Sub I2_Click()
I2.Visible = False
I1.Visible = True
Me.Height = 3225
online.Height = 2760
SYSETc.Top = 2675
Text1.Height = 350
For a = 0 To 3
sb(a).Top = 2700
Next
End Sub

Private Sub listen_ConnectionRequest(ByVal requestID As Long)
On Error Resume Next
Connected = Connected + 1
Load connect1(Connected)
connect1(Connected).Accept requestID
End Sub


Private Sub online_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)