Attribute VB_Name = "Database"
Public dbConn As ADODB.Connection
Public dbOpen As Boolean

Sub OpenDatabase(strDSN As String)
    Set dbConn = New ADODB.Connection

    dbConn.Open "DSN=" & strDSN

    dbOpen = True
End Sub

Function GetSpaceNumber(strType As String) As Long
    Select Case strType
        Case "Include"
        Case "Object"
        Case "Class"
        Case "Grammar"
    End Select
End Function

Sub GetClassList(objList As Object)
    Dim rs As ADODB.Recordset
    If dbOpen Then
        Set rs = dbConn.Execute("Select * From Class")
        Do Until rs.EOF
            objList.AddItem rs("ClassName")
            objList.ItemData(objList.NewIndex) = rs("ClassId")
            rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
    End If
End Sub
Sub GetParentList(objList As Object, Optional lngObjectId As Long)
    Dim rs As ADODB.Recordset
    If dbOpen Then
        If Not IsMissing(lngObjectId) Then
            Set rs = dbConn.Execute("Select * From Object Where ObjectId <> " & lngObjectId)
        Else
            Set rs = dbConn.Execute("Select * From Object")
        End If
        Do Until rs.EOF
            objList.AddItem rs("ObjectName")
            objList.ItemData(objList.NewIndex) = rs("ObjectId")
            rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
    End If
End Sub
Function GetPropertyList(objList As Object)
    Dim rs As ADODB.Recordset
    If dbOpen Then
        Set rs = dbConn.Execute("Select * From Property")
        Do Until rs.EOF
            objList.AddItem rs("PropertyName")
            objList.ItemData(objList.NewIndex) = rs("PropertyId")
            rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
    End If
End Function
Function GetAttributeList(objList As Object)
    Dim rs As ADODB.Recordset
    If dbOpen Then
        Set rs = dbConn.Execute("Select * From Attribute")
        Do Until rs.EOF
            objList.AddItem rs("AttributeName")
            objList.ItemData(objList.NewIndex) = rs("AttributeId")
            rs.MoveNext
        Loop
        rs.Close
        Set rs = Nothing
    End If
End Function

Function RunSQLReturnRS(ByVal strSQL As String) As ADODB.Recordset
    On Error GoTo errorHandler
    
    ' Set up Command and Connection objects
    Dim rs As ADODB.Recordset
    Dim cmd As ADODB.Command
    Dim cs As String
    Set rs = New ADODB.Recordset
    Set cmd = New ADODB.Command

    'Run the procedure

    cmd.ActiveConnection = strConnection
    cmd.CommandText = strSQL
    cmd.CommandType = adCmdText
    
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenForwardOnly, adLockReadOnly
    
    ' Disconnect the recordsets and cleanup
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    Set rs.ActiveConnection = Nothing
    
    Set RunSQLReturnRS = rs
    Exit Function
    
errorHandler:
    Set rs = Nothing
    Set cmd = Nothing
End Function

Function RunSQL(ByVal strSQL As String)
    On Error GoTo errorHandler
    
    ' Create the ADO objects
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command

    ' Init the ADO objects & the stored proc parameters
    cmd.ActiveConnection = strConnection
    cmd.CommandText = strSQL
    cmd.CommandType = adCmdText
    
    ' Execute the query without returning a recordset
    cmd.Execute , , adExecuteNoRecords
    
    ' Cleanup
    Set cmd.ActiveConnection = Nothing
    Set cmd = Nothing
    
    Exit Function
    
errorHandler:
    Set cmd = Nothing
    If Err.Number = -2147217900 Then
        Err.Raise 3000, "DBConnection", "Username is already used. Please try another."
    End If
End Function