sckrecordset.bas

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

Attribute VB_Name = "SckRecordset"
Dim StrUser As String 'Without "/" port #
Dim OldUser As String 'with "/" Port #
Public Folders As String
Public CacheFolder As String
Public CurrentMsg As Long 'tells this module what current record we are dealing with for deleting records
Dim StrMessage As Variant
Public MessageCounter As Long 'tells the client what message count we are up to (for the single messages function)
Public Allusers As String 'allows the client to see all the registred users.
Public IusrCom, IusrName, IusrAddy, IusrAddy1, IusrPhone, IusrFax, IusrEmail, IusrIP, IusrWeb As String
Public AcPOP, AcSmtp, AcAccount, AcPass As String

Public Sub sckUserName(UserName As String)
On Error GoTo UsrErr
Dim rs As ADODB.Recordset                   'This subroutine checks the database
Set rs = New ADODB.Recordset                'to see if the person logging in actually
Dim ChkLogon As MultiSck
Set ChkLogon = New MultiSck
Dim Sql As String                           'has an account here.
OldUser = UserName & "/" & FrmServer.sckmax 'orginal winsock port
UserName = Split(UserName, Chr(10))(1)
Sql = "Select UserName from Users where UserName = " _
& Chr(34) & UserName & Chr(34)

rs.Open Sql, cn, adOpenForwardOnly, adLockReadOnly

If UCase(UserName) = UCase(rs!UserName) Then
StrUser = rs!UserName   'make this public for this module and then verify it with the password
'Call ChkLogon.parseuser(UserName & "/" & FrmServer.sckmax)
                                    'now that the user is in the database, we must
                                    'find out the exact port his is on or we will
                                    'get criscross passwords.
Call ChkLogon.GetSck5(UserName)
End If

Set ChkLogon = Nothing
rs.Close
Set rs = Nothing
Exit Sub

UsrErr:

    Dim UserErr As MultiSck
    Set UserErr = New MultiSck
        OldUser = Split(OldUser, "/")(1)
        UserErr.UsrErr OldUser, True
    Set UserErr = Nothing

End Sub

Public Sub sckPassword(Password As String)
On Error GoTo PassErr
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim Sql As String
Dim ChkPass As MultiSck
Set ChkPass = New MultiSck

Password = Split(Password, Chr(10))(1)

Sql = "Select * from Users where UserName = " _
& Chr(34) & StrUser & Chr(34)

rs.Open Sql, cn, adOpenForwardOnly, adLockReadOnly
'Debug.Print Password & rs!Password

    If UCase(rs!Password) = UCase(Password) Then
        ChkPass.GetSck6 (StrUser)
       
    Else
        GoTo PassErr
    End If
    
rs.Close
Set rs = Nothing
Set ChkPass = Nothing
Exit Sub
PassErr:
    Dim PasswordErr As MultiSck
    Set PasswordErr = New MultiSck
        OldUser = Split(OldUser, "/")(1)
        PasswordErr.PassErr OldUser, True
    Set PasswordErr = Nothing

End Sub
Public Sub DelFolder(Folder As String)
On Error Resume Next

Set Table = DB.TableDefs(StrUser)

Table.Fields.Delete Folder


If Err.Description = "" Then
    Dim FolderUpdate As MultiSck
    Set FolderUpdate = New MultiSck
        With FolderUpdate
            DoEvents
            .GetSck (StrUser)
            DoEvents
            .DelFolder (Folder)
        End With
    Set FolderUpdate = Nothing
Else
    Dim ErrUpdate As MultiSck
    Set ErrUpdate = New MultiSck
        With ErrUpdate
            .GetSck (StrUser)
            .ErrFolder (Folder)
        End With
    Set ErrUpdate = Nothing
End If
End Sub
Public Sub NewFolder(Folder As String)
Set Table = DB.TableDefs(StrUser)
Set FL = Table.CreateField(Folder, dbMemo)
On Error Resume Next
Table.Fields.Append FL

If Err.Description = "" Then '*
    Dim FolderUpdate As MultiSck
    Set FolderUpdate = New MultiSck     'sends user the new folder if
        With FolderUpdate               'it was successfully created
            DoEvents
            .GetSck (StrUser)           'in database.
            .AddFolder (Folder)
        End With
    Set FolderUpdate = Nothing
Else
    Dim ErrUpdate As MultiSck           'if theres an error tell user
    Set ErrUpdate = New MultiSck        'that the folder has'nt been
        With ErrUpdate                  'created.
            .GetSck (StrUser)
            .ErrFolder (Folder)
        End With
    Set ErrUpdate = Nothing
End If
End Sub

Public Sub DBMessages(UserName As String)
Dim i As Integer
Dim strFields As String
Dim strInbox, strID, StrSub, strFrom, strDate As String
Dim GetFolder As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim NewUser As Long
Dim Read As String
GetFolder = Split(UserName, Chr(10))(1)
UserName = Split(UserName, Chr(10))(0)

rs.Open "select * from [" & UserName & "]", cn, adOpenStatic, adLockReadOnly

        For i = 3 To 3
            For j = 1 To rs.RecordCount
            If IsNull(rs.Fields(GetFolder)) = True Then GoTo MoveNext
                strID = "~*~" & rs!Msgid
                strFrom = "~!~" & rs!From
                StrSub = "~#~" & rs!Subject
                If InStr(1, rs.Fields(GetFolder), "[~N10~]", vbTextCompare) = 0 Then Read = "Y" Else Read = "N"
                strInbox = "~@~" & rs.Fields(GetFolder)
                strDate = "~^~" & rs!Rdate & "