VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'-----------------------------------------------------
' MirageBot Database Class
' Written by Christopher Nevin (lancergli@gmail.com)
'-----------------------------------------------------

Option Explicit
Option Compare Text

Private DatabasePath As String
Private Users() As New objDbUser

Public Sub Optimize()
    Dim X As Integer
    For X = 0 To UBound(Users)
        Dim R As RankingStruct
        R = modRanks.GetRankByID(Users(X).RankID)
        If Len(R.RankName) = 0 Then
            Remove Users(X).Username
        End If
    Next
End Sub

Public Function Count() As Integer
On Error Resume Next
    Count = UBound(Users)
End Function

Public Function GetUsers() As objDbUser()
    GetUsers = Users
End Function

Public Function GetUser(Index As Integer) As objDbUser
On Error GoTo hErr:
    If Index = -1 Then GoTo hErr
    Set GetUser = Users(Index)
    Exit Function
hErr:
    Set GetUser = Nothing
End Function

Public Sub SetUser(Index As Integer, User As objDbUser)
On Error Resume Next
    Set Users(Index) = User
End Sub

Public Sub Clear()
    ReDim Users(0)
End Sub

Public Sub Reload()
    Load DatabasePath
End Sub

Public Sub Load(p As String)
On Error GoTo hErr:
    DatabasePath = p
    ReDim Users(0)
    Dim FF As Integer, Content As String, Line As Long
    FF = FreeFile
    Open DatabasePath For Append As #FF
    Close #FF
    Open DatabasePath For Input As #FF
        Do Until EOF(FF) Or Err
            Line Input #FF, Content
            Line = Line + 1
            If InStrB(Content, "#") <> 0 Then
                Dim Data() As String, Out As String
                Data = Split(Content, "#")
                If UBound(Data) = 4 Then
                    If Not Add(Data(0), Data(1), Data(2), Data(3), Data(4), Out, False) Then
                        'Debug.Print "Cannot add user at line: " & Line & " -- " & Out
                    End If
                Else
                    'Debug.Print "Invalid user at line: " & Line
                End If
            End If
        Loop
    Close #FF
    Save
    Exit Sub
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "Database", "Load"
End Sub

Public Sub Save()
    Dim FF As Integer: FF = FreeFile
    Open DatabasePath For Append As #FF
    Close #FF
    Open DatabasePath For Output As #FF
        Dim I As Integer, C As Integer
        C = UBound(Users)
        For I = 0 To C
            Print #FF, Users(I).Username & "#" & GetRankByID(Users(I).RankID).RankName & "#" & Users(I).AddTime & "#" & Users(I).AddDate & "#" & Users(I).AddBy
        Next I
    Close #FF
End Sub

Public Function Add(User As String, Rank As String, _
    Optional AddTime As String = vbNS, _
    Optional AddDate As String = vbNS, _
    Optional AddBy As String = "[Console]", _
    Optional Out As String = vbNS, _
    Optional DoSave As Boolean = True) As Boolean
    
    If LenB(Rank) = 0 Then: Out = "Invalid rank specified!": Exit Function
    If RankingExists(Rank) = False Then: Out = "Rank does not exist!": Exit Function
    If GetRanking(Rank).UserGroup = False Then Add = False: Out = "Rank does not allow users to be added to it!": Exit Function
    If GetRanking(Rank).PatternMatch Then
        If InStr(User, "*") = 0 Then Add = False: Out = "Rank only allows patterns to be added to it!": Exit Function
        If FindPattern(User) > -1 Then: Out = "Pattern already exists!": Exit Function
        Dim NUser As String
        NUser = Replace(User, "*", vbNS)
        If LenB(NUser) = 0 Then Add = False: Out = "Pattern must include characters other than wildcards!": Exit Function
        NUser = vbNS
    Else
        If LenB(User) = 0 Then: Out = "Please specify a user to add!": Exit Function
        If InStr(User, "*") <> 0 Then Add = False: Out = "Rank does not accept wildcards!": Exit Function
        If Find(User, False) > -1 Then: Out = "User already exists!": Exit Function
    End If
    If LenB(AddTime) = 0 Then AddTime = Format$(Time, "hh:mm")
    If LenB(AddDate) = 0 Then AddDate = Date
    If LenB(AddBy) = 0 Then AddBy = "[Console]"
    
    Dim IU As New objDbUser
    With IU
        .AddBy = AddBy
        .AddDate = AddDate
        .AddTime = AddTime
        .RankID = GetIDByRank(Rank)
        .Username = User
    End With
    
    If LenB(Users(0).Username) Then ReDim Preserve Users(UBound(Users) + 1)
    Set Users(UBound(Users)) = IU
    
    Add = True
    If DoSave Then Save
End Function

Public Function FindPattern(ByVal User As String) As Integer
    If LenB(User) = 0 Then FindPattern = -2: Exit Function
    Dim I As Integer, C As Integer
    User = User
    C = UBound(Users)
    For I = C To 0 Step -1
        If User = Users(I).Username Then
            FindPattern = I
            Exit Function
        End If
    Next I
    FindPattern = -1
End Function

Public Function Find(ByVal User As String, Optional PatternMatching As Boolean = True) As Integer
    If LenB(User) = 0 Then Find = -2: Exit Function
    Dim I As Integer, C As Integer
    User = TruncNumber(Suffix(User))
    C = UBound(Users)
    For I = C To 0 Step -1
        If User = Suffix(Users(I).Username) Then Find = I: Exit Function
    Next I
    If PatternMatching Then
        For I = C To 0 Step -1
            If Matches(User, Users(I).Username) Then
                If GetRankByID(Users(I).RankID).PatternMatch Then Find = I
                Exit Function
            End If
        Next I
    End If
    Find = -1
End Function

Public Function MatchUser(ByVal Match As String, ByRef Result() As Integer) As Boolean
    If LenB(Match) = 0 Then MatchUser = False: Exit Function
    Dim I() As Integer, X As Integer, C As Integer
    ReDim I(0): I(0) = -1
    C = UBound(Users)
    For X = C To 0 Step -1
        If Matches(Users(X).Username, Match) Then
            If I(0) = -1 Then
                I(0) = X
            Else
                ReDim Preserve I(UBound(I) + 1)
                I(UBound(I)) = X
            End If
        End If
    Next X
    If I(0) <> -1 Then MatchUser = True
    Result = I
End Function

Public Function Remove(ByVal User As String) As Boolean
On Error GoTo hErr:
    Dim I As Integer, R As Integer, C As Integer
    User = User
    C = UBound(Users)
    If C = 0 Then
        If Users(0).Username = User Then
            ReDim Users(0)
            Remove = True
            Save
            Exit Function
        End If
    End If
    For I = 0 To C
        If User = Users(I).Username Then
            C = UBound(Users) - 1
            For R = I To C
                Set Users(R) = Users(R + 1)
            Next R
            ReDim Preserve Users(C)
            Remove = True
            Save
            Exit Function
        End If
    Next I
    Exit Function
hErr:
    ErrorHandler Err.Number, Err.Description, Erl, "Database", "Remove"
End Function

Public Function CountRanked(Rank As String) As Integer
    Dim Ranked() As String, I As Integer, C As Integer, CR As Integer
    C = UBound(Users)
    For I = 0 To C
        If GetRankByID(Users(I).RankID).RankName = Rank Or GetRankByID(Users(I).RankID).Alias = Rank Then
            CR = CR + 1
        End If
    Next I
    CountRanked = CR
End Function

Public Function GetRanked(Rank As String) As String()
    Dim Ranked() As String, I As Integer, C As Integer
    C = UBound(Users)
    ReDim Ranked(0)
    For I = 0 To C
        If GetRankByID(Users(I).RankID).RankName = Rank Or GetRankByID(Users(I).RankID).Alias = Rank Then
            If LenB(Ranked(0)) = 0 Then
                Ranked(0) = Users(I).Username
            Else
                ReDim Preserve Ranked(UBound(Ranked) + 1)
                Ranked(UBound(Ranked)) = Users(I).Username
            End If
        End If
    Next I
    GetRanked = Ranked()
End Function

Public Sub Class_Initialize()
    ReDim Users(0) As New objDbUser
End Sub

Public Sub Class_Terminate()
    On Error Resume Next
    ReDim Users(0)
End Sub

