frmserver.frm

基于C-S结构的办公信息数据处理系。经检测绝对可用。类似OutLook界面。

If Mid$(GetRecv, 1, 12) = "DeleteFolder" Then
    GetRecv = Split(GetRecv, "GetMessages")(0) 'incase of error
    Call DelFolder(Mid$(GetRecv, 14, Len(GetRecv)))
End If

If Mid$(GetRecv, 1, 11) = "GetMessages" Then '*
    Dim GetMessages As MultiSck
    Set GetMessages = New MultiSck
        GetMessages.GetSck2 (Mid$(GetRecv, 13, Len(GetRecv)))
        GetMessages.SendMsgs (Mid$(GetRecv, 13, Len(GetRecv)))
     
    Set GetMessages = Nothing

End If

If Mid$(GetRecv, 1, 14) = "ExportMessages" Then '*
    Dim ExportM As MultiSck
    Set ExportM = New MultiSck
        
        ExportM.GetSck2 (Mid$(GetRecv, 15, Len(GetRecv)))
        ExportM.SendExport (Mid$(GetRecv, 15, Len(GetRecv)))
     
    Set ExportM = Nothing

End If


If Mid$(GetRecv, 1, 11) = "DragMessage" Then
On Error Resume Next
    Dim User, Folder, From, Subj, Discript, Rdate, Msgid, StrUser As String
        GetRecv = Mid$(GetRecv, 12, Len(GetRecv))
        User = Split(GetRecv, Chr(10))(0)
        Folder = Split(GetRecv, Chr(10))(1): Folder = Split(Folder, "~F~")(0)
        From = Split(GetRecv, "~F~")(1): From = Split(From, "~~")(0)
        Subj = Split(GetRecv, "~~")(1): Subj = Split(Subj, "~~")(0)
        Rdate = Split(GetRecv, "~~")(2) ': Rdate = Split(Rdate, "~~")(1)
        Msgid = Split(GetRecv, "~~")(3)
        Discript = Split(GetRecv, "~~")(4)
        StrUser = Split(GetRecv, "~~")(5)
        StrUser = Split(StrUser, "Edit")(0) 'avoiding multi key select error
        
        SckRecordset.MoveRecord User, Folder, From, Subj, Discript, Rdate, Msgid, StrUser
End If

If Mid$(GetRecv, 1, 12) = "DeleteRecord" Then
        Call SckRecordset.DelRecord(Mid$(GetRecv, 14, Len(GetRecv)))
End If

If Mid$(GetRecv, 1, 10) = "DelMessage" Then

    Dim GetUser As String
    Dim DelRecord As Long
    GetRecv = Split(GetRecv, "EditMessage")(0) 'incase of error
    GetRecv = Split(GetRecv, "DelMessage")(0) 'incase of error
    GetUser = Split(Mid$(GetRecv, 11, Len(GetRecv)), Chr(10))(0)
    DelRecord = Split(Mid$(GetRecv, 11, Len(GetRecv)), Chr(10))(1)
    Call DelMessage(GetUser, DelRecord)
End If

If Mid$(GetRecv, 1, 10) = "NewMessage" Then
    Dim strWho, StrSub, StrMsg, SvMsg, Tdate As String
    Dim MsgCounter As Long
    Dim Notification As MultiSck
    Set Notification = New MultiSck
    
    SvMsg = Mid$(GetRecv, 11, Len(GetRecv))
        strWho = Split(SvMsg, "~~")(0)
        StrUser = Split(SvMsg, "~~")(1)
        StrSub = Split(SvMsg, "~~")(2)
        SvMsg = Split(SvMsg, "~~")(3)
        Tdate = Date
        
            Call NewMessage(StrUser, strWho, StrSub, SvMsg, Tdate)
            Call SentMessage(StrUser, strWho, StrSub, SvMsg, Tdate)

            Call MessageCount(StrUser)  'get recordset count
            MsgCounter = SckRecordset.MessageCounter    'new message id for listview
            Notification.GetSck4 (StrUser)  'get socket number
            Notification.Notifiy strWho, StrSub, SvMsg, Tdate, MsgCounter
            
        Set Notification = Nothing
            If InStr(1, GetRecv, "OpenFile,") > 0 Then _
            GetRecv = Split(GetRecv, Chr(10))(1) 'send attachment

        
End If

If Mid$(GetRecv, 1, 5) = "Email" Then
    Dim EmMsg, EmDate As String
    Dim EmUser As String
    Dim EmWho As String
    Dim EmSub As String
    EmMsg = Mid$(GetRecv, 6, Len(GetRecv))
        EmWho = Split(EmMsg, "~~")(0)
        EmUser = Split(EmMsg, "~~")(1)
        EmSub = Split(EmMsg, "~~")(2)
        EmMsg = Split(EmMsg, "~~")(3)
        EmDate = Date
          
        MailIDcheck EmUser
        MailTOcheck EmWho
          
         
        EmInbox Recordsets.usrEmail, Recordsets.UsrToEmail, EmMsg, EmDate, EmSub
        If GetRegKey(HKEY_LOCAL_MACHINE, "Office Server", "SendDirect", "") = "True" Then Mnu3SndRecv_Click
    
            
End If


If Mid$(GetRecv, 1, 11) = "EditMessage" Then
    Dim strEditUsr, strEditRec, strEditFld, strEditMsg, strSvMsg As String
    strSvMsg = Mid$(GetRecv, 12, Len(GetRecv))
        strEditUsr = Split(strSvMsg, "~~")(0)
        strEditRec = Split(strSvMsg, "~~")(1)
        strEditFld = Split(strSvMsg, "~~")(2)
        strEditMsg = Split(strSvMsg, "~~")(3)
        
        Call EditMessage(strEditUsr, strEditRec, strEditFld, strEditMsg)
End If

If Mid$(GetRecv, 1, 8) = "EmptyBin" Then
        Call SckRecordset.EmptyBin(Mid$(GetRecv, 9, Len(GetRecv)))
        
End If

If Mid$(GetRecv, 1, 7) = "ComData" Then
    CompressData.User = Mid$(GetRecv, 8, Len(GetRecv))
    mnuCompress_Click
End If

If Mid$(GetRecv, 1, 11) = "RegisterNew" Then
    Dim RDetails As String
    Dim RName, RAddy, RAddy1, RCountry, RPhone, RFax, Rcom, _
    REmail, RWebsite, RPass As String
        RDetails = Mid$(GetRecv, 12, Len(GetRecv))
        
        RName = Split(RDetails, "~~~")(0)
        RAddy = Split(RDetails, "~~~")(1)
        RAddy1 = Split(RDetails, "~~~")(2)
        RCountry = Split(RDetails, "~~~")(3)
        RPhone = Split(RDetails, "~~~")(4)
        RFax = Split(RDetails, "~~~")(5)
        Rcom = Split(RDetails, "~~~")(6)
        REmail = Split(RDetails, "~~~")(7)
        RWebsite = Split(RDetails, "~~~")(8)
        RPass = Split(RDetails, "~~~")(9)
        
    Call NewAccount(RName, RAddy, RAddy1, RCountry, RPhone, RFax, _
    Rcom, REmail, RWebsite, RPass)
'name, address, address1, country, phone, fax, company,
'email, website, password
        
        rego.MSGUsrSuccess

End If





If Mid$(GetRecv, 1, 10) = "GetMailAcc" Then
    Dim SendAccount As MultiSck
    Set SendAccount = New MultiSck
        Dim AccName As String
            AccName = Mid$(GetRecv, 11, Len(GetRecv))
                SendAccount.GetSck2 AccName
                SendAccount.GetMailAcc AccName
    Set SendAccount = Nothing
    
End If

If Mid$(GetRecv, 1, 8) = "SaveMail" Then
    Dim SvUser, SvPop, SvSmtp, SvAccount, SvPass As String
    SvUser = Split(Mid$(GetRecv, 9, Len(GetRecv)), Chr(10))(0)
    SvPop = Split(Mid$(GetRecv, 9, Len(GetRecv)), Chr(10))(1)
    SvSmtp = Split(Mid$(GetRecv, 9, Len(GetRecv)), Chr(10))(2)

   
    Recordsets.SvEmailAcc SvUser, SvPop, SvSmtp

End If



ExitRoutine: 'dont write code pass this point



End Sub


Private Sub Timer1_Timer()
Dim DBStat As String
If ODBC.DBConnect = True Then DBStat = "Open" Else DBStat = "Closed"
Label7.Caption = "Current Connections "
Label8.Caption = "(" & Userlist.ListCount & ")" & "  " & "(" & ActiveCon & ")"
Label2.Caption = "Database = " & DBStat & " (OSDB.mdb) "
End Sub

Public Sub DelLstDup(listBox As listBox)
On Error GoTo exitdel
' *** Removes any dupes incase server makes a mistake
    Dim a%, b%
    For a% = 0 To listBox.ListCount - 1
        For b% = 0 To listBox.ListCount - 1
            If b% <> a% Then
                If Split(listBox.List(a%), "/")(0) = Split(listBox.List(b%), "/")(0) Then
                    listBox.RemoveItem a%
                    'listBox.RemoveItem "" ' if the listbox finds a "" entry remove it!
                    b% = b% - 1
                End If
            End If
        Next b%
    Next a%
    Exit Sub
exitdel:
    Exit Sub
End Sub
Public Sub usrPorts()
On Error Resume Next
Dim i As Integer
Dim sckPorts As Long
    For i = 0 To Userlist.ListCount - 1
        sckPorts = Split(Userlist.List(i), "/")(1)
        ServerSck(sckPorts).SendData "UserList" _
        & Chr(10) & List
    DoEvents
    Next i
End Sub

Public Sub UsrList()
Dim User As Integer
    List = ""
    For User = 0 To Userlist.ListCount - 1
        List = List & Split(Userlist.List _
        (User), "/")(0) & "_"
    Next User

End Sub
Public Sub UsrRemove(UserName As String, Port As Long)
On Error Resume Next
Dim i As Integer
Dim j As Integer
Dim sckPorts As Long
For i = 0 To Userlist.ListCount - 1
    If Userlist.List(i) = UserName & "/" & Port Then _
    Userlist.RemoveItem ((i))
    Call UsrList
Next i

For j = 0 To Userlist.ListCount - 1
    sckPorts = Split(Userlist.List(j), "/")(1)
        ServerSck(sckPorts).SendData "UserList" _
        & Chr(10) & List
        DoEvents
Call UsrList
Next j

End Sub
Private Sub CreateHeaders()
FrmStart.Label1.Caption = "Creating Headers"
LVMsgs.ColumnHeaders.Clear

With LVMsgs.ColumnHeaders
    .Add , , , 270
    .Add , , "To", 2200
    .Add , , "From", 1650
    

End With

End Sub
Private Sub Timer2_Timer()
Dim LiveUser As String
Dim LiveIP, i As Long
On Error Resume Next
    For i = 0 To Userlist.ListCount
        LiveUser = Userlist.List(i)
        LiveIP = Split(LiveUser, "/")(1)
            If ServerSck.Item(LiveIP).State <> 7 Then
                Userlist.RemoveItem (i)
                Call UsrList
                Call Broadcast("UserList" & Chr(10) & List)
            End If
    Next i



End Sub
Private Sub Broadcast(BrMessage As String)
Dim CastUser As String
Dim CastIP, i As Long
    For i = 0 To Userlist.ListCount - 1
        CastUser = Userlist.List(i)
        CastIP = Split(CastUser, "/")(1)
            ServerSck.Item(CastIP).SendData BrMessage
    Next i

End Sub

Private Sub Timer3_Timer()
    If Mtimer.Elapsed > CheckMailTmr * 60000 Then
    Mnu3SndRecv_Click
    Mtimer.Reset
    End If
End Sub

Private Sub Userlist_DblClick()
Dim Person As String
Dim IP As Long
    Dim GetInfo As FrmUser
    Set GetInfo = New FrmUser
        
        Person = Split(Userlist.Text, "/")(0)
        IP = Split(Userlist.Text, "/")(1)
        Call GetUserInfo(Person)
    With GetInfo
            .Caption = "User Info: " & Person
            .Label15.Caption = Me.ServerSck(IP).RemoteHostIP
            .Label8.Caption = Recordsets.usrCom
            .Label9.Caption = Recordsets.usrName
            .Label10.Caption = Recordsets.usrAddy
            .Label11.Caption = Recordsets.usrAddy1
            .Label12.Caption = Recordsets.usrPhone
            .Label13.Caption = Recordsets.usrFax
            .Label14.Caption = Recordsets.usrEmail
    End With
    GetInfo.Show 1
    
    Set GetInfo = Nothing

End Sub