frmmain.frm

来自「使用VB仿QQ界面开发的ICQ程序,采用C/S结架,实现简单文字聊天.」· FRM 代码 · 共 773 行 · 第 1/2 页

End Sub

'----------------------
Private Sub Form_Terminate()
  Shell_NotifyIcon NIM_DELETE, Tic
End Sub

'生成ICO托盘图标.
Private Sub DoSystrayIcon()
    Tic.cbSize = Len(Tic)
    Tic.hWnd = Me.hWnd
    Tic.uID = vbNull
    Tic.uFlags = NIF_DOALL
    Tic.uCallbackMessage = WM_MOUSEMOVE
    Tic.hIcon = Me.Icon
    Tic.sTip = "Instant Messenger Server" & vbNullChar
    rc = Shell_NotifyIcon(NIM_ADD, Tic)
End Sub

'将菜单项变成托盘菜单.
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
        Dim msg As Long
        Dim sFilter As String
        msg = x / Screen.TwipsPerPixelX
        Select Case msg
            Case WM_RBUTTONUP
                PopupMenu mnuSystray
            Case WM_LBUTTONDBLCLK
                Me.Show
                'Me.WindowState = vbNormal
        End Select
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 If Not FinalClose Then
   'Me.WindowState = 1
    Me.Hide
    Cancel = 1
 End If
End Sub
'----------------------

Private Sub mnuExit_Click()
Dim Ans2 As Byte
Ans2 = MsgBox("Are you sure you would like to end this Server?", vbYesNo + vbQuestion, "Are you sure?")
If Ans2 = vbYes Then
    FinalClose = True
    Shell_NotifyIcon NIM_DELETE, Tic
    Unload Me
    End
  Else
    Exit Sub
End If
End Sub

Private Sub mnuAbout_Click()
frmAbout.Show 1
End Sub

Private Sub mnuOption_Click()
  frmOptions.Show 1
End Sub

Private Sub mnuRestore_Click()
  Me.Show
  'Me.WindowState = vbNormal
End Sub

Private Sub mnuSystrayExit_Click()
  Call mnuExit_Click
End Sub

Private Sub mnuSystrayOption_Click()
  frmOptions.Show 1
End Sub

Private Sub ServiceSocket_Close(Index As Integer)
   
   ServiceSocket(Index).Close
 
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim rs2 As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 Dim user As String
 conn.Open sConnString
 
 'Deletes user from ONLINE database when he signs off
 rs2.Open "SELECT username FROM online where oindex = " + _
            CStr(Index), conn
 If Not rs2.EOF Then
    user = rs2.Fields("username")
End If
  rs.Open "DELETE * FROM online WHERE oindex = " + _
                CStr(Index), conn

    Call update_status(2, user, Index)
   RichTextBox1.SelColor = vbRed
   RichTextBox1.SelText = Now & ": Connected closed for " & ServiceSocket(Index).RemoteHostIP & vbCrLf
Set rs = Nothing
Set rs2 = Nothing
Set conn = Nothing
End Sub

Private Sub ServiceSocket_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    If Index = 0 Then
        intMax = intMax + 1
        
        'load new socket
        Load ServiceSocket(intMax)
        ServiceSocket(intMax).LocalPort = 0
        ServiceSocket(intMax).Accept requestID
        
        RichTextBox1.SelColor = vbBlue
        RichTextBox1.SelText = Now & ": New connection request from " & ServiceSocket(intMax).RemoteHostIP & vbCrLf
    End If
End Sub

Private Sub ServiceSocket_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    Dim strIncoming As String
    Dim result As String
    'Store incoming data into strIncoming
    ServiceSocket(Index).GetData strIncoming
    
    'List of If statements looking at the FIRST word in strIncoming
    If Word(strIncoming, 1) = ".login" Then 'Compare username and pass to database
        result = login_user(Word(strIncoming, 2), Word(strIncoming, 3), Index)
        ServiceSocket(Index).SendData result
          
    ElseIf Word(strIncoming, 1) = ".getonlinebuddies" Then
        Call get_online_buddies(Word(strIncoming, 2), Index)
        
    ElseIf Word(strIncoming, 1) = ".updateStatus" Then 'Updates User status: online, away, etc
        Call update_status(Word(strIncoming, 2), Word(strIncoming, 3), Index)
    
    ElseIf Word(strIncoming, 1) = ".updateBuddy" Then
        Call update_buddy(Word(strIncoming, 2), Word(strIncoming, 3), Word(strIncoming, 4), Index)
        
    ElseIf Word(strIncoming, 1) = ".newBuddy" Then
        Call new_buddy(Word(strIncoming, 2), Word(strIncoming, 3), Index)
        
    ElseIf Word(strIncoming, 1) = ".delBuddy" Then
        Call del_buddy(Word(strIncoming, 2), Word(strIncoming, 3), Index)
        
    ElseIf Word(strIncoming, 1) = ".msg" Then
        Call send_message(Word(strIncoming, 2), Word(strIncoming, 3), strIncoming, Index)
        
    ElseIf Word(strIncoming, 1) = ".define" Or Word(strIncoming, 1) = ".spell" Then
        Call get_DefineSpell(Word(strIncoming, 1), Word(strIncoming, 2), Word(strIncoming, 3), Index)
        
    End If
    
End Sub

Private Function get_DefineSpell(df As String, buddy As String, wordtD As String, Index As Integer)
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=defin.mdb"
 Dim rs As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 Dim sendmsg As String
 Dim I As Integer
 conn.Open sConnString

sendmsg = df & " " & buddy & " " & wordtD

Select Case df
    Case ".define"
        rs.Open "SELECT type, definition FROM words WHERE word = '" + _
                    CStr(wordtD) + "' ", conn
        If Not rs.EOF Then
            I = 0
            sendmsg = sendmsg & " ..//.. " & rs.Fields("type") & " "
            While Not rs.EOF And I < 3
                I = I + 1
                sendmsg = sendmsg & I & ". " & rs.Fields("definition") & " "
                rs.MoveNext
            Wend
        Else
            sendmsg = sendmsg & " ..//.. undefined term"
        End If
        ServiceSocket(Index).SendData sendmsg
    Case ".spell"
        rs.Open "SELECT word FROM words WHERE word = '" + _
                    CStr(wordtD) + "' ", conn
        If Not rs.EOF Then
            sendmsg = sendmsg & " ..//.. " & wordtD & " is spelled correctly."
        Else
            sendmsg = sendmsg & " ..//.. " & wordtD & " appears to be misspelled."
        End If
        ServiceSocket(Index).SendData sendmsg
End Select
            
End Function

Private Function send_message(mfrom As String, mto As String, msg As String, Index As Integer)
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 Dim sendmsg As String
 Dim I As Long
 conn.Open sConnString
    rs.Open "SELECT oindex, ostatus FROM online WHERE username = '" + _
            CStr(mto) + "' ", conn
    If Not rs.EOF Then
        sendmsg = SplitString(msg, "..//..")
        If ServiceSocket(rs.Fields("oindex")).State = sckConnected Then
            ServiceSocket(rs.Fields("oindex")).SendData ".msg " & mfrom & " ..//.. " & sendmsg
            DoEvents: DoEvents
            ServiceSocket(Index).SendData ".msgOK 0"
        Else
            ServiceSocket(Index).SendData ".msgOK 1"
        End If
    Else
        ServiceSocket(Index).SendData ".msgOK 1"
    End If
Set rs = Nothing
Set conn = Nothing
End Function

Private Function del_buddy(user As String, delbuddy As String, Index As Integer)
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 conn.Open sConnString
    rs.Open "DELETE * FROM buddies WHERE user = '" + _
            CStr(user) + "' AND buddy = '" + _
            CStr(delbuddy) + "' ", conn
     ServiceSocket(Index).SendData ".statusUpdate 0 "
Set rs = Nothing
Set conn = Nothing
End Function

Private Function new_buddy(user As String, newbuddy As String, Index As Integer)
    
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim rs2 As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 conn.Open sConnString
    
    rs2.Open "INSERT INTO buddies ([user], [buddy]) VALUES('" + _
        CStr(user) + "', '" + _
        CStr(newbuddy) + "') ", conn
    
  rs.Open "SELECT username, ostatus FROM online WHERE username = '" + _
            CStr(newbuddy) + "' ", conn
  If Not rs.EOF Then
     ServiceSocket(Index).SendData ".statusUpdate 1 " & newbuddy & " " & rs.Fields("ostatus")
  Else
     ServiceSocket(Index).SendData ".statusUpdate 1 " & newbuddy & " 2"
  End If
Set rs = Nothing
Set rs2 = Nothing
Set conn = Nothing
End Function

Private Function update_buddy(user As String, oldbuddy As String, newbuddy As String, Index As Integer)
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim rs2 As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 conn.Open sConnString
 
  rs2.Open "UPDATE buddies SET buddy = '" + _
            CStr(newbuddy) + "' WHERE user = '" + _
            CStr(user) + "' AND buddy = '" + _
            CStr(oldbuddy) + "' ", conn

  rs.Open "SELECT username, ostatus FROM online WHERE username = '" + _
            CStr(newbuddy) + "' ", conn
  If Not rs.EOF Then
     ServiceSocket(Index).SendData ".statusUpdate 1 " & newbuddy & " " & rs.Fields("ostatus")
  Else
     ServiceSocket(Index).SendData ".statusUpdate 1 " & newbuddy & " 2"
  End If
Set rs = Nothing
Set rs2 = Nothing
Set conn = Nothing
End Function

Private Function login_user(user As String, pass As String, Index As Integer) As String
 Dim I As Integer
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim rs2 As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 conn.Open sConnString
 
  rs.Open "SELECT username, password FROM users WHERE username = '" + _
            CStr(user) + "' " + _
            " AND password = '" + CStr(pass) + "' ", conn
  If Not rs.EOF Then
    login_user = ".goodlogin" 'Username and Passoword are correct
        'When .goodlogin, add user to ONLINE table
        rs2.Open "INSERT INTO online (username, signontime, oindex) VALUES('" + _
            CStr(user) + "', '" + _
            CStr(Now) + "', '" + _
            CStr(Index) + "') ", conn
  Else
    login_user = ".badlogin" 'Username or Password is wrong
  End If
Set rs = Nothing
Set rs2 = Nothing
Set conn = Nothing
End Function

Private Function get_online_buddies(user As String, Index As Integer)
 Dim OnlineBuddies As String
 Dim status As Integer
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim rs2 As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 conn.Open sConnString
        'Get user's buddies that are online
        rs.Open "SELECT buddy FROM buddies WHERE user = '" + _
                    CStr(user) + "' ", conn
        While rs.EOF = False
            rs2.Open "SELECT username, ostatus FROM online WHERE username = '" + _
                CStr(rs.Fields("buddy")) + "' ", conn
            If Not rs2.EOF Then
                status = rs2.Fields("ostatus")
            Else
                status = 2
            End If
            OnlineBuddies = OnlineBuddies & " " & rs.Fields("buddy") & status
            rs2.Close
        rs.MoveNext
        Wend
        If OnlineBuddies <> "" Then
            ServiceSocket(Index).SendData ".showonline 1" & OnlineBuddies
        Else
            ServiceSocket(Index).SendData ".showonline 0"
        End If
Set rs = Nothing
Set rs2 = Nothing
Set conn = Nothing
End Function

Private Function update_status(status As Integer, user As String, Index As Integer)
 Dim sConnString  As String
 sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=imdb.mdb"
 Dim rs As New ADODB.Recordset
 Dim rs2 As New ADODB.Recordset
 Dim conn As New ADODB.Connection
 conn.Open sConnString
 If ServiceSocket(Index).State = sckConnected Then
        rs2.Open "UPDATE online SET ostatus = " + _
                CStr(status) + " WHERE username = '" + _
                CStr(user) + "' AND oindex = " + _
                CStr(Index), conn
 End If
                
        'Gets the ppl that have user as buddies that are currently online
        rs.Open "SELECT buddy, oindex FROM buddies, online WHERE buddies.buddy = '" + _
                    CStr(user) + "' AND buddies.user = online.username", conn
        While rs.EOF = False
        'Im not too sure about this part of the code...it seems it would work, not sure
        'if its the best code though
            For I = 1 To ServiceSocket.UBound
            testing = ServiceSocket(I).Index
                If ServiceSocket(I).Index = rs.Fields("oindex") Then
                    If ServiceSocket(I).State = sckConnected Then
                        ServiceSocket(I).SendData ".statusUpdate 1" & " " & user & " " & status 'send status of user to its buddies if their online
                    End If
                End If
            Next I
        rs.MoveNext
        Wend
 If ServiceSocket(Index).State = sckConnected Then
    ServiceSocket(Index).SendData ".statusUpdate 0"
 End If
 Set rs = Nothing
 Set rs2 = Nothing
 Set conn = Nothing
End Function