frmserver.frm

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

      End
      Begin VB.Menu mnuExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu Mnu2 
      Caption         =   "&View"
      Begin VB.Menu MnuProfile 
         Caption         =   "&View User Profiles"
      End
      Begin VB.Menu MnuDelivery 
         Caption         =   "&Delivery Options"
      End
   End
   Begin VB.Menu Mnu3 
      Caption         =   "&Mail"
      Begin VB.Menu mnu3OutGo 
         Caption         =   "&Process Outgoing Mail"
      End
      Begin VB.Menu Mnu3SndRecv 
         Caption         =   "&Send Mail"
      End
   End
   Begin VB.Menu mnuTools 
      Caption         =   "&Tools"
      Begin VB.Menu mnuCompress 
         Caption         =   "&Compress Database"
      End
   End
   Begin VB.Menu mnu4 
      Caption         =   "&Help"
      Begin VB.Menu sep7 
         Caption         =   "-"
      End
      Begin VB.Menu mnu4About 
         Caption         =   "A&bout"
      End
   End
End
Attribute VB_Name = "FrmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public sckmax As Integer 'Winsock multi connections
Public SndUserList As Boolean ' new user logged in? if TRUE then send online list
Dim List As String 'Actual list of users
Public ActiveCon As Long 'How many connections are allow to the server
Public CheckMailTmr As Long
Dim FileInit As Long
Public Mtimer As New MailTimer
Private Sub Form_Load()
Me.Hide
FrmStart.Label1.Caption = "Loading Server......"
DoEvents
FrmStart.Show
        ADOConnect
If ODBC.DBConnect = True Then
        Call CreateHeaders
        openDAO
   Call LdEMail
End If

ServerSck(0).LocalPort = 9456           'Sets the local port for the first sock
ServerSck(0).Listen
Me.Label5.Caption = "Server IP: " & ServerSck(0).LocalIP
Me.Label6.Caption = ""

On Error Resume Next
If GetRegKey(HKEY_LOCAL_MACHINE, "Office Server", "CheckState", "") = "True" Then Timer3.Enabled = True
CheckMailTmr = GetRegKey(HKEY_LOCAL_MACHINE, "Office Server", "SndRec", "")

'FrmStart.Hide


End Sub

Private Sub Form_Resize()
On Error Resume Next
RichTextBox1.Width = Me.Width - 3900
LVMsgs.Width = Me.Width - 3900
Label3.Width = Me.Width - 3900
Label4.Width = Me.Width - 3900
LVMsgs.ColumnHeaders.Item(2).Width = Me.Width - 6200
Shape1.Width = Me.Width
LVMsgs.Height = Me.Height - 6000
Label4.Top = Me.Height - 4250
RichTextBox1.Top = Me.Height - 3900
Userlist.Height = Me.Height - 2400
If Label4.Top - 1000 < LVMsgs.Top Then RichTextBox1.Top = 3000: LVMsgs.Height = 930: Label4.Top = 2680: RichTextBox1.Height = Me.Height - 3700


End Sub

Private Sub Form_Unload(Cancel As Integer)
cn.Close
DB.Close
Set DB = Nothing
Set cn = Nothing
End
End Sub
Private Sub SendMailQue()
Dim i As Integer
Dim emID As Long
 If InternetGetConnectedState(0&, 0&) = 1 Then
    For i = 1 To LVMsgs.ListItems.Count
        emID = LVMsgs.ListItems.Item(i).Text
            Call EmOutBox(emID)
            Call EmRemove(emID)
    Next i
    LVMsgs.ListItems.Clear
End If

Unload FrmConnector

End Sub
Private Sub mnu3OutGo_Click()

    If LVMsgs.ListItems.Count = 0 Then
        MsgBox "No mail to send", vbExclamation + vbOKOnly, "Checking Outgoing Mail"
            Exit Sub
    End If

Call SendMailQue


End Sub

Public Sub SendMail(POPAddy, RecvMail, FromAddy, strFrom, ToAddy, Subject, Message As String)
On Error GoTo MailError
Message = Split(Message, "[~N10~]")(0)
sockMail.Close
sockMail.Connect POPAddy, "25"

Do While sockMail.State <> sckConnected

If sockMail.State = sckClosed Then
repsonse = MsgBox("Error Can't Establish Connection " & vbCrLf & "  Retry Connecting?", vbInformation + vbYesNo, "Can't Find Connection")
If repsonse = vbYes Then

Else

GoTo unloadit
End If
End If
DoEvents

Loop
RichTextBox1.Text = RichTextBox1.Text & vbCrLf & vbCrLf & "Session Open:" & vbNewLine
sockMail.SendData "MAIL FROM: " & "[e-mail]" & Chr$(13) & Chr$(10) 'leave this incase of error
DoEvents

sockMail.SendData "RCPT TO: " & RecvMail & Chr$(13) & Chr$(10) ' recievers email address"
DoEvents
RichTextBox1.Text = RichTextBox1.Text & Time & ":  " & "Sending Message to " & ToAddy & vbNewLine
RichTextBox1.Text = RichTextBox1.Text & Time & ":  " & "Subject:  " & Subject & vbNewLine

sockMail.SendData "DATA" & Chr$(13) & Chr$(10)
DoEvents
RichTextBox1.Text = RichTextBox1.Text & Time & ":  " & "Communicating to " & POPAddy & vbNewLine

sockMail.SendData "FROM: " & FromAddy & " <" & FromAddy & ">" & Chr$(13) & Chr$(10)
sockMail.SendData "TO: " & strFrom & " <" & ToAddy & ">" & Chr$(13) & Chr$(10)
sockMail.SendData "SUBJECT: " & Subject & Chr$(13) & Chr$(10)
sockMail.SendData Data & Message
sockMail.SendData Chr$(13) & Chr$(10) & "." & Chr$(13) & Chr$(10)
DoEvents

sockMail.SendData "QUIT" & Chr$(13) & Chr$(10)

RichTextBox1.Text = RichTextBox1.Text & "Message Sent!       " & Time & "    " & _
Format(Now, "short Date") & vbNewLine & "Closing Session:" & vbCrLf & "***********************************************" & vbCrLf
RichTextBox1.SelStart = Len(RichTextBox1.Text)
sockMail.Close

unloadit:

Exit Sub
    On Error Resume Next
MailError:
    
  If IsNull(POPAddy) = True Then POPAddy = "POP Server ERROR!"
    RichTextBox1.Text = RichTextBox1.Text & vbCrLf & cbcrlf & "Error Posting Message" & _
    vbCrLf & "POP SERVER: = " & POPAddy & vbCrLf & "Mail To: = " & ToAddy & vbCrLf & _
    "Mail From: = " & FromAddy & vbCrLf & "Subject: = " & Subject & vbCrLf & "Message Dump" & vbCrLf & Message & vbCrLf & _
    vbCrLf & "Deleting Message from que" & vbCrLf & "Closing Session:" & vbCrLf & "***********************************************" & vbCrLf
RichTextBox1.SelStart = Len(RichTextBox1.Text)

sockMail.Close


End Sub

Private Sub Mnu3SndRecv_Click()
        
On Error GoTo cancheck

With FrmConnector
    .Show vbOLEDisplayContent, Me
        .Label1.Caption = "Connecting to Mail Servers"
        FrmConnector.Caption = "Connecting to Mail Servers"
     InternetAutodial INTERNET_AUTODIAL_FORCE_UNATTENDED, 0

        .Label1.Caption = "Sending..."

    If LVMsgs.ListItems.Count = 0 Then
        Unload FrmConnector
    Exit Sub
        Else
        Call SendMailQue
    End If


  
  End With

cancheck:
End Sub

Private Sub mnu4About_Click()
'FrmStart.Label4.Caption = "Office Server" & vbCrLf & vbCrLf & "Beta Version 1.0"
'FrmStart.Label3 = "Author: Chris Hatton": FrmStart.Label3.ToolTipText = "Email: [e-mail]"
FrmStart.Timer1.Enabled = False
FrmStart.Label1.Caption = ODBC.MSDatabase
FrmStart.Show 1
End Sub

Private Sub mnuCompress_Click()
Call CompactJetDatabase(App.Path & "\OSDB.mdb")
End Sub

Private Sub MnuDelivery_Click()
FrmMailOpt.Show 1
End Sub

Private Sub mnuExit_Click()
End
End Sub

Private Sub MnuProfile_Click()
ClearForm
RegUsers    'display user accounts
FrmProfile.Show 1
End Sub

Private Sub ServerSck_ConnectionRequest(Index As Integer, ByVal requestID As Long)
On Error Resume Next
        sckmax = sckmax + 1                                     'Increases the user count
        Load ServerSck(sckmax)                                 'Loads a new socket
        ServerSck(sckmax).LocalPort = 0                        'Sets a random port to listen to
        ServerSck(sckmax).Accept requestID                     'Accept the user
            If Userlist.ListCount + 1 > ActiveCon Then
                ServerSck(sckmax).SendData "NoConnection"
               
                    Exit Sub
            End If

        ServerSck(sckmax).SendData "welcome" & Chr(10)         'Tell the user that they are connected
   
   
End Sub
Private Sub ServerSck_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim GetRecv As String

    Dim Command      As String
    Dim NewArrival   As String
    Dim Data         As String
    Static DataCnt   As Long
   ServerSck(Index).GetData GetRecv
Debug.Print GetRecv


On Error GoTo ExitRoutine

If Mid$(GetRecv, 1, 9) = "VUserName" Then
    Userlist.AddItem Split(Mid(GetRecv, 10, Len(GetRecv)), Chr(10))(1) & "/" & Index
    DelLstDup Userlist
    
    Call SckRecordset.sckUserName(Mid(GetRecv, 10, Len(GetRecv)))
End If

If Mid$(GetRecv, 1, 9) = "VPassword" Then
    Call SckRecordset.sckPassword(Mid(GetRecv, 10, Len(GetRecv)))
End If

If Mid$(GetRecv, 1, 11) = "GetUserList" Then
    Dim FindPort As MultiSck
    Set FindPort = New MultiSck
        FindPort.GetSck Mid$(GetRecv, 12, 12)   'User is requesting list, get there port number
        
        Call UsrList    'gets the all the users in a single string
        
        Call usrPorts   'get all the active user ports to send userlist to.
    Set FindPort = Nothing
    
    End If

If Mid$(GetRecv, 1, 7) = "SignOff" Then
    Dim SignoffPort As MultiSck
    Set SignoffPort = New MultiSck
        SignoffPort.GetSck Mid$(GetRecv, 8, Len(GetRecv))
        Call UsrRemove(Mid$(GetRecv, 8, Len(GetRecv)), SignoffPort.Sck)
    Set SignoffPort = Nothing
    End If
    
If Mid$(GetRecv, 1, 7) = "OffList" Then '*
    Dim LstOffline As MultiSck
    Set LstOffline = New MultiSck
        LstOffline.GetSck (Mid$(GetRecv, 8, Len(GetRecv)))
        LstOffline.LstOffline
      
    Set LstOffline = Nothing
End If


If Mid$(GetRecv, 1, 7) = "GetInfo" Then '*
    Dim Iuser As String
    Dim Iport As String
    Dim GetUsrInfo As MultiSck
    Set GetUsrInfo = New MultiSck
        Iport = Split(Mid$(GetRecv, 8, Len(GetRecv)), Chr(10))(0)
        GetUsrInfo.GetSck Iport
        Iuser = Split(Mid$(GetRecv, 8, Len(GetRecv)), Chr(10))(1)
        GetUsrInfo.GetUserI Iuser
    Set GetUsrInfo = Nothing
    
End If


If Mid$(GetRecv, 1, 12) = "CreateFolder" Then
    
    Call NewFolder(Mid$(GetRecv, 14, Len(GetRecv)))
    
End If

If Mid$(GetRecv, 1, 13) = "CustomFolders" Then Call GetFolders(Mid$(GetRecv, 14, Len(GetRecv)))