ADO Utility Class

This is an ADO class containing useful functions (counting records, creating database from scratch, openning/closing database, filling listbox/combo box with an sql statements, manipulating records....and much more)

Comments and suggestion are most welcome. '---------------------------------------------------------------------------------
' Module    : clsADO
' Author    : (c)2002 Francis Jamet
' Remark    : You may use this Class for personal project. However, I will
'            appreciate if you add my name to your credits. If you want to
'            use this Class for commercial purpose, please contact me first
'            to [email protected], fees will apply (not much, but still this is
'            normal)
'---------------------------------------------------------------------------------
'===============================================================================
' REFERENCES TO BE ADDED:
' Microsoft ActiveX Data Object 2.x Library (for the connection)
' Microsoft ADO Ext. 2.x for DLL and security (for cretating database)
' Microsoft Jet And Replication 2.x Objects Library (for compacting)
'===============================================================================
'Force the definition of the variables
Option Explicit
'This value will be return if the password isn't found
Private Const sNoPassword As String = "-No password found-"
'Use by GetPreviousNextID function
Public Enum eDirection
    ePrevious = 0
    eNext = 1
End Enum
'Use to know which kind of connection we need
Public Enum DBFormat
    eJET = 0
    eODBC = 1 'SQL
    eFoxPro = 2
End Enum
'Use in the CreateDatabase function
Public Enum AccessVersion
    Access2000 = 0
    Access97 = 1
    AccessXP = 2
End Enum
'Store regesty information
Public dbPath As String
Public dbFileName As String
'Create an instance of the object connection
Public cnn As ADODB.Connection
'===============================================================================
' Desc : Set the registry key for the current application
' Param :
' Return: <nothing>
'===============================================================================
Public Sub SetAppInfo(DbName As String)
    If GetSetting(App.Title, "Control", "Title") = "" Then
        Call SaveSetting(App.Title, "Control", "Title", App.Title)
        Call SaveSetting(App.Title, "Control", "Version", App.Major & "." & App.Minor & "." & App.Revision)
        Call SaveSetting(App.Title, "Install", "Date", Now())
        Call SaveSetting(App.Title, "Install", "AppPath", App.Path)
        Call SaveSetting(App.Title, "NCS", "Copyright", "(c)" & Year(Date))
        Call SaveSetting(App.Title, "Data", "DBName", DbName)
        Call SaveSetting(App.Title, "Data", "DBPath", App.Path & "\Data")
    End If
End Sub
'===============================================================================
' Desc : Set the default path and name of the database
' Param : <none>
' Return: <nothing>
'===============================================================================
Public Sub GetDBInfo()
    dbPath = GetSetting(App.Title, "Data", "DBPath")
    dbFileName = GetSetting(App.Title, "Data", "DBName")
End Sub
'===============================================================================
' Desc : Create a new connection and open the database through the Jet engine
' Param :
' Return: <nothing>
'===============================================================================
Public Sub OpenDBADO(Optional DbName As String, Optional DatabaseEngine As DBFormat = 0, Optional sSourcePath As String, Optional isExclusive As Boolean)
On Error GoTo ErrorHandler
    Dim sCnnString As String
    Dim sExclusive As String
   
    'Create a new instance of a ADO Connection
    Set cnn = New ADODB.Connection
   
    'If the open is call implicitly
    If DbName = "" Then
        Call GetDBInfo
        DbName = dbPath & "\" & dbFileName
    End If
   
    If isExclusive Then
        sExclusive = "Oui"
    Else
        sExclusive = "Non"
    End If
   
    Select Case DatabaseEngine
        Case DBFormat.eJET
            'Connection with JET 4.0 (VB with service pack 5)
            sCnnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source="
        Case DBFormat.eFoxPro
            sCnnString = "UID=;" & _
                        "PWD=;" & _
                        "SourceDB=;" & _
                        "SourceType=DBF;" & _
                        "Exclusive=No;" & _
                        "BackgroundFetch=Yes;" & _
                        "Collate=Machine;" & _
                        "Null=No;" & _
                        "Deleted=No;" & _
                        "DSN="
        Case DBFormat.eODBC
            sCnnString = "Provider=MSDASQL.1;" & _
                        "Persist Security Info=False;" & _
                        "Data Source="
    End Select
    cnn.Open sCnnString & DbName
Exit_Sub:
    Exit Sub
ErrorHandler:
    If Err.Number = -2147467259 Then
        MsgBox "Connection problem with SQL Server. The server may be down, " & _
            "check with the network administrator", vbCritical
    Else
        MsgBox Err.Number & " - " & Err.Description
    End If
    Err.Clear
    Resume Exit_Sub
End Sub

'===============================================================================
' Desc : Close the connection and Destroy the cnn object
' Param : <none>
' Return: <nothing>
'===============================================================================
Public Sub CloseDBADO()
On Error GoTo ErrorHandler
    'Close the connection
    If cnn.State = 1 Then cnn.Close
   
Exit_Sub:
    'Destroy the cnn object
'    Set cnn = Nothing
    Exit Sub
   
ErrorHandler:
    'If the connection object is already closed
    If Err.Number = 91 Then
        Err.Clear
        Resume Exit_Sub
    End If
    MsgBox Err.Number & "-" & Err.Description
    Err.Clear
    Resume Exit_Sub
End Sub

'===============================================================================
' Desc : Use to return the amount of data found, based on the SQL criteria
' Param :
'        tblName : Table name
'        sWhere : Condition (Ex:City_Name="Montreal")
' Return: The count number
'===============================================================================
Public Function HowManyData(tblName As String, Optional sWhere As String) As Long
    On Error GoTo ErrorHandler
    Dim sSQL As String
    Dim RS As ADODB.Recordset
   
    'Create a recorset object
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenStatic
   
    'If there is a condtion, append it to the SQL statement
    If Len(sWhere) > 0 Then
        If InStr(1, UCase(sWhere), "WHERE") <> 0 Then
            sSQL = "SELECT * FROM " & tblName & " " & sWhere
        Else
            sSQL = "SELECT * FROM " & tblName & " WHERE " & sWhere
        End If
    Else
        sSQL = "SELECT * FROM " & tblName
    End If
   
    'Open the recordset based on the sSQL
'    Debug.Print sSQL
    RS.Open sSQL, cnn
   
    'Assign the number of recordset found
    HowManyData = RS.RecordCount
   
    'Close the recordset
    RS.Close
   
Exit_Function:
    'Destroy the recorset object
    Set RS = Nothing
    Exit Function
   
ErrorHandler:
    Call HandleError(Err.Number)
    Err.Clear
    Resume Exit_Function
End Function
Public Function HowManyDataSQL(sSQLtoCount As String) As Long
    On Error GoTo ErrorHandler
    Dim RS As ADODB.Recordset
   
    'Create a recorset object
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenStatic
    'Debug.Print sSQLtoCount
    'Open the recordset based on the sSQLtoCount
    RS.Open sSQLtoCount, cnn
   
    'Assign the number of recordset found
    HowManyDataSQL = RS.RecordCount
   
    'Close the recordset
    RS.Close
   
Exit_Function:
    'Destroy the recorset object
    Set RS = Nothing
    Exit Function
   
ErrorHandler:
    Call HandleError(Err.Number)
    Err.Clear
    Resume Exit_Function
End Function
'===============================================================================
' Desc : Based on a SQL statement, return the required value. If nothing is
'        found, the function return -2 (we use -2 insted of -1, because if
'        the funtion return a boolean value (True/False, Yes/No) the numeric
'        value of TRUE or YES is -1)
' Param :
'        sSQL : SQL statement (Ex.:Select City_Name From City Where City=1)
' Return: Fields(0) or -2
'===============================================================================
Public Function GetDataSQL(sSQL As String) As Variant
    On Error GoTo ErrorHandler
   
    Dim RS As ADODB.Recordset
   
    'Create a new instance or a recordset
    Set RS = New ADODB.Recordset
   
    'Open the recordset based on the sSQL
    RS.Open sSQL, cnn
   
    'If the data was found, return the first field. Otherwise
    'return -2
    If Not isRSEmpty(RS) Then
        GetDataSQL = RS.Fields(0)
    Else
        GetDataSQL = -2
    End If
   
Exit_Function:
    'Destroy the recordset object
    Set RS = Nothing
    Exit Function
ErrorHandler:
MsgBox Err.Description
    Call HandleError(Err.Number)
    Err.Clear
    Resume Exit_Function
End Function

'===============================================================================
' Desc : This procedure use a SQL statement to fill a ListBox or a ComboBox
' Param :
'        frm    = Form holding the [ListBox] or [ComboBox]
'        ctrlName = Name of the [ListBox] or [ComboBox]
'        sSql    = SQL Statement. The statement must have two fields, an ID
'                    number and a value to display on the screen. For example:
'                    "Select City, City_Name From City"
' Return: <nothing>
'===============================================================================
Public Sub FilllstcboBox(frm As Form, ctrlName As String, sSQL As String, Optional cboIndex As Integer = -1)
    On Error GoTo ErrorHandler
    Dim RS As ADODB.Recordset
    Dim iField0 As Integer
    Dim sField1 As String
   
    'Create a new instance or a recordset
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenStatic
    'Open the recordset based on the sSQL
    RS.Open sSQL, cnn
   
    'Be sure to be at the beggining of the recordset
    If Not RS.EOF Then
        RS.MoveLast
        RS.MoveFirst
    End If
   
    'Until you reach the end of the recordset, fill the control
    While Not RS.EOF
   
        If RS.Fields.Count = 1 Then
            iField0 = 1
            sField1 = IIf(IsNull(RS.Fields(0)), "", RS.Fields(0))
        Else
            iField0 = IIf(IsNull(RS.Fields(0)), 0, RS.Fields(0))
            sField1 = IIf(IsNull(RS.Fields(1)), "", RS.Fields(1))
        End If
   
   
        If Len(sField1) > 1 Then
            If cboIndex < 0 Then
                frm.Controls(ctrlName).AddItem sField1
                frm.Controls(ctrlName).ItemData(frm.Controls(ctrlName).NewIndex) = iField0
            Else
                'same procedure for an array of combo/list box
                frm.Controls(ctrlName)(cboIndex).AddItem sField1
                frm.Controls(ctrlName)(cboIndex).ItemData(frm.Controls(ctrlName)(cboIndex).NewIndex) = iField0
            End If
        End If
        RS.MoveNext
    Wend
   
    'Close the recordset
    RS.Close
   
Exit_Sub:
    'Destroy the recordset object
    Set RS = Nothing
    Exit Sub
   
ErrorHandler:
    Debug.Print "*** FILLLSTCBOBOX (CLSADO) ************************************************"
    Debug.Print Time() & ": ERROR # " & Err.Number
    Debug.Print "Description : " & Err.Description
    Debug.Print "SQL = " & sSQL
    Debug.Print "***************************************************************************"
    Call HandleError(Err.Number)
    Err.Clear
    Resume Exit_Sub
End Sub

'===============================================================================
' Desc : Use to check if a recordset is empty or not
' Param :
'        RS: Recordset Object
' Return: True or False
'===============================================================================
Public Function isRSEmpty(RS As ADODB.Recordset) As Boolean
    isRSEmpty = ((RS.BOF = True) And (RS.EOF = True))
End Function

'===============================================================================
' Desc : Run a sql statement
' Param :
'        sSQL : Sql statement (use for Insert, Update or Delete)
' Return: A long value (Err.Number)
'===============================================================================
Public Function ExecuteSQL(sSQL As String) As Long
On Error GoTo ErrorHandler
   
    If GetSetting(App.Title, "Control", "DebugMode") = "TRUE" Then
        Debug.Print sSQL
    End If
       
    Call cnn.Execute(sSQL)
    'Debug.Print cnn.ConnectionString
    'Assing the error number as return value, if there is no error, it will
    'be 0
    ExecuteSQL = Err.Number
Exit_Sub:
    Exit Function
   
ErrorHandler:
    Debug.Print "***************************************************************************"
    Debug.Print Time() & ": ERROR # " & Err.Number
    Debug.Print "Description : " & Err.Description
    Debug.Print "SQL = " & sSQL
    Debug.Print "***************************************************************************"
    ExecuteSQL = Err.Number
    Err.Clear
    Resume Exit_Sub
End Function
'===============================================================================
' Desc : Process the errors
' Param :
'        ErrNumber : The system error number
' Return: <nothing>
'===============================================================================
Private Sub HandleError(ErrNumber As Long)
    Dim sMsg As String
    'Based on the error number
    Select Case ErrNumber
        Case -2147467259
            sMsg = "Cannont access the table, probably locked or open in design monde"
        Case Else
            sMsg = Err.Description
            Debug.Print Time() & ":" & Err.Number & "-" & sMsg
            sMsg = ""
    End Select
   
    'If the sMsg is not empty
    If sMsg <> "" Then MsgBox sMsg
End Sub
'===============================================================================
' Desc : Read from the disk SQL statements saved in a files
' Param :
'        sqlFileName : Name of the SQL File
' Return:
'        The SQL statement
'===============================================================================
Public Function GetSQL(sqlFileName As String) As String
    Dim sTmp, sSQL As String
    sqlFileName = "SQL\" & sqlFileName & ".SQL"
    Open sqlFileName For Input As #1
        While Not EOF(1)
            Line Input #1, sTmp
            sSQL = sSQL & Chr(32) & sTmp
        Wend
    Close #1
    GetSQL = Trim(sSQL)
End Function
'===============================================================================
' Desc : Is the user have administration rights
' Param :
'        UserName : User name to check
' Return:
'        True if the user are admin
'===============================================================================
Public Function isAdmin(UserName As String) As Boolean
    isAdmin = GetDataSQL("Select [ADM_Right] FROM [User] WHERE [Usr_UserName]=" & _
            PutQuotes(UserName)) = True
End Function
'===============================================================================
' Desc : Get the user password
' Param :
'        UserName : User name
' Return:
'        The password
'===============================================================================
Public Function GetUserPassword(UserName As String, Optional fldName As String, Optional fldPass As String, Optional tblName As String) As String
    On Error GoTo ErrorHandler
    Dim RS As ADODB.Recordset
    Dim strsql As String
   
    If fldName <> "" Then
        strsql = "SELECT [" & fldPass & "] " & _
                "FROM [" & tblName & "] " & _
                "WHERE [" & fldName & "] = " & PutQuotes(UserName)
    Else
        strsql = "SELECT [Usr_Password] " & _
                "FROM [USER] " & _
                "WHERE [Usr_UserName] = " & PutQuotes(UserName)
    End If
    Debug.Print strsql
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenStatic
    RS.Open strsql, cnn
   
    If RS.RecordCount <= 0 Then
        GetUserPassword = sNoPassword
    Else
        GetUserPassword = RS.Fields(0)
    End If
   
Exit_Function:
    RS.Close
    'Call CloseDBADO
    Set RS = Nothing
    Exit Function
   
ErrorHandler:
    MsgBox Err.Number & vbCrLf & Err.Description
    Err.Clear
    Resume Exit_Function
End Function
Public Function GetNoPasswordMessage() As String
    GetNoPasswordMessage = sNoPassword
End Function
'===============================================================================
' Desc : Delete a table
' Param :
'        tblName : Name of the table to delete
' Return: <nothing>
'===============================================================================
Public Sub DropTable(tblName As String)
On Error GoTo ErrorHandler
    Dim RS As ADODB.Recordset
    Dim strsql As String
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenKeyset
    RS.LockType = adLockOptimistic
    strsql = "DROP TABLE " & tblName
    RS.Open strsql, cnn
Exit_Sub:
    'RS.Close
    Set RS = Nothing
    Exit Sub
ErrorHandler:
    'MsgBox Err.Number & " " & Err.Description
    Err.Clear
End Sub

'===============================================================================
' Desc : Create a new MDB file
' Param :
'        dbName    : Name of the MDB file
'        DBVersion : Enum showing the possibility to create the MDB for
'                    Access 2000 or Access 97
' Return: <nothing>
'===============================================================================
Public Sub CreateDatabase(DbName As String, DBVersion As AccessVersion)
    Dim newDB As New ADOX.Catalog
    If DBVersion = Access2000 Then
        'For ACCESS 2000
        newDB.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & App.Path & "\" & DbName
    Else
        'For ACCESS 97
        newDB.Create "Provider=Microsoft.Jet.OLEDB.3.51;" & _
                    "Data Source=" & App.Path & "\" & DbName
    End If
    Set newDB = Nothing
End Sub

'===============================================================================
' Desc : Create a new table in the database
' Param :
'        dbName    : Name of the MDB file
'        tblName : Name of the new table
'        fldName : Name of the fields and their DataType (fldName,DataType
'                    ex.:Cust_Name, Text)
' Return: <nothing>
'===============================================================================
Public Sub CreateTable(DbName As String, tblName As String, fldName() As String, Optional PrimaryKey As String)
    Dim adoc As New clsADO
    Dim sSQL As String
    Dim iCount As Integer
    Dim sField As String
    Dim sDataType As String

    sSQL = "CREATE TABLE " & tblName & " ("
    For iCount = 0 To UBound(fldName()) - 1
        Call SplitFieldDataType(fldName(iCount), sField, sDataType)
        sSQL = sSQL & sField & " " & sDataType
        If iCount < UBound(fldName()) - 1 Then
            sSQL = sSQL & ","
        End If
    Next iCount
    If PrimaryKey = "" Then
        sSQL = sSQL & ")"
    Else
        sSQL = sSQL & "," & PrimaryKey & ")"
    End If
    Call adoc.OpenDBADO(App.Path & "\" & DbName)
    'Debug.Print sSQL
    Call adoc.ExecuteSQL(sSQL)
    Call adoc.CloseDBADO
    Set adoc = Nothing
End Sub
'===============================================================================
' Desc : Split a string in two part, the field name and his data type
' Param :
'        sFldDT    : The string to separate (ex:"Cust_Name|String(20)")
'        sField    : Storing in the address of the calling variable(ByRef),
'                    the name of the field ("Cust_Name")
'        sDataType : Storing in the address of the calling variable(ByRef),
'                    the data type of the field ("String(20)")
' Return: <nothing>
'===============================================================================
Private Sub SplitFieldDataType(sFldDT As String, ByRef sField As String, ByRef sDataType As String)
    sField = Left(sFldDT, InStr(1, sFldDT, "|") - 1)
    sDataType = Mid(sFldDT, InStr(1, sFldDT, "|") + 1)
End Sub
'===============================================================================
' Desc : Compact a database (MDB)
' Param :
'        dbPathAndName : The path and name of the DB to compact. If nothing is
'                        set for this variable, the system will take the current
'                        DB (set in GetDBInfo)
'        MakeBackup    : If its true make a copy of the DB
' Return: <nothing>
'===============================================================================
Public Sub CompactDatabase(Optional dbPathAndName As String, Optional MakeBackup As Boolean)
    Dim JRO As New JRO.JetEngine
    If dbPathAndName <> "" Then
        If MakeBackup Then Call FileCopy(dbPathAndName, dbPathAndName & ".bak")
        JRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & dbPathAndName, _
                            "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & App.Path & "\dtnetCompact.mdb;" & _
                            "Jet OLEDB:Engine Type=4"
        Call Kill(dbPathAndName)
        Name App.Path & "\BakCompact.mdb" As dbPathAndName
    Else
        Call GetDBInfo
        If MakeBackup Then Call FileCopy(dbPath & dbFileName, dbPath & dbFileName & ".bak")
        JRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & dbPath & dbFileName, _
                            "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & App.Path & "\dtnetCompact.mdb;" & _
                            "Jet OLEDB:Engine Type=4"
        Call Kill(dbPath & dbFileName)
        Name dbPath & "\BakCompact.mdb" As dbPath & dbFileName
    End If
    Set JRO = Nothing
End Sub
'=================================================================================
' Desc : This function surround a string by quotes. You need to call
'        this procedure each time you want to put a string value inside
'        a SQL statement
' Param :
'        txtToQuote : String to surround with quotes
' Return: The string surrounded by quotes
'=================================================================================
Public Function PutQuotes(ByRef txtToQuote As String, Optional isSQLServer As Boolean) As String
    Dim iASCII As Integer
   
    If isSQLServer Then
        iASCII = 39
    Else
        iASCII = 34
    End If
   
    PutQuotes = Chr(iASCII) & txtToQuote & Chr(iASCII)
End Function
'===============================================================================
' Desc : Export a SQL result to a Comma-Separated Value File (CSV)
' Param :
'        sPath    : Path of the exported CSV file
'        sFileName : The CSV filename
'        sSQL    : The query result to export
' Return: <nothing>
'===============================================================================
Public Sub ExportToCSV(sPath As String, sFileName As String, sSQL As String)
    Dim iPortFile As Integer
    Dim RS As ADODB.Recordset
    Dim iCount As Integer
    Dim sField As String
   
    'Create a new instance or a recordset
    Set RS = New ADODB.Recordset
    RS.CursorType = adOpenStatic
    'Open the recordset based on the sSQL
    RS.Open sSQL, cnn
   
    iPortFile = FreeFile
   
    'Be sure to be at the beggining of the recordset
    If Not RS.EOF Then
        RS.MoveLast
        RS.MoveFirst
    End If
   
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    If InStr(1, LCase(sFileName), ".csv") = 0 Then sFileName = sFileName & ".csv"
   
    Open sPath & sFileName For Output As #iPortFile
   
    For iCount = 0 To RS.Fields.Count - 1
        sField = "" & RS.Fields(iCount).Name
        Write #iPortFile, sField;
    Next iCount
   
    Write #iPortFile,
    RS.MoveFirst
   
    While Not RS.EOF
        For iCount = 0 To RS.Fields.Count - 1
            sField = "" & RS.Fields(iCount)
            Write #iPortFile, sField;
        Next iCount
        Write #iPortFile,
        RS.MoveNext
    Wend
   
    RS.Close
    Close #iPortFile
   
    Set RS = Nothing
End Sub
'===============================================================================
' Desc : Get the previous or the next ID of the current one
' Param :
'        sSQL    : The query
'        lCurrent : The current ID
'        iDirection : If you need the Previous or the Next
' Return: <nothing>
'===============================================================================
Public Function GetPreviousNextID(sSQL As String, lCurrentID As Long, iDirection As eDirection) As Long
    Dim RS As ADODB.Recordset
   
    'Create a new instance or a recordset
    Set RS = New ADODB.Recordset
   
    'Allow the recordset to be searched in any direction
    RS.CursorType = adOpenKeyset
   
    'Open the recordset based on the sSQL
    RS.Open sSQL, cnn
   
   
    If isRSEmpty(RS) Then
        'If the data wasn't found, return -2
        GetPreviousNextID = -2
    Else
        RS.Find RS.Fields(0).Name & "=" & lCurrentID
        Select Case iDirection
            Case eDirection.ePrevious
                RS.MovePrevious
                If Not RS.BOF Then
                    GetPreviousNextID = RS.Fields(0)
                Else
                    GetPreviousNextID = lCurrentID
                End If
            Case eDirection.eNext
                If Not RS.EOF Then RS.MoveNext
                If Not RS.EOF Then
                    GetPreviousNextID = RS.Fields(0)
                Else
                    GetPreviousNextID = lCurrentID
                End If
        End Select
       
    End If
   
    RS.Close
    Set RS = Nothing
End Function
Public Function DoubleSingleQuote(sText As String) As String
    Dim iCount As Integer
    Dim sTmp As String
   
    For iCount = 1 To Len(sText)
        If Mid(sText, iCount, 1) = Chr(39) Then
            sTmp = sTmp & Mid(sText, iCount, 1) & Chr(39)
        Else
            sTmp = sTmp & Mid(sText, iCount, 1)
        End If
       
    Next iCount
    DoubleSingleQuote = sTmp
End Function
Public Function ReplaceCharBy(sText As String, sSource As String, sByWhat As String) As String
    Dim iCount As Integer
    For iCount = 1 To Len(sText)
        If Mid(sText, iCount, 1) = sSource Then Mid(sText, iCount, 1) = sByWhat
    Next iCount
    ReplaceCharBy = sText
End Function
Public Function CreateNextID(sTbl As String, sFld As String, cAdoLocal As clsADO) As Long
On Error GoTo ErrorHandler
    Dim sSQL As String
    Dim lID As Long
   
    'Check if the connection was establish
    Debug.Print cnn.State
   
    sSQL = "SELECT TOP 1 " & sFld & " FROM " & sTbl & " ORDER BY " & sFld & " DESC"
    lID = cAdoLocal.GetDataSQL(sSQL)
    If lID <= 0 Then
        lID = 1
    Else
        lID = lID + 1
    End If
   
    CreateNextID = lID
   
Exit_Function:
    Exit Function
ErrorHandler:
    If Err.Number = 91 Then
        MsgBox "Aucune connection n'a été établi!"
        Err.Clear
        Resume Exit_Function
    End If
End Function
Public Function isTableExist(cAdotmp As clsADO, sTable As String) As Boolean
On Error GoTo ErrorHandler
    Dim sSQL As String
    Dim Rstmp As New ADODB.Recordset
    sSQL = "SELECT TOP 1 * FROM " & sTable
    Rstmp.Open sSQL, cAdotmp.cnn
    isTableExist = True
Exit_Function:
    If Rstmp.State = 1 Then Rstmp.Close
    Set Rstmp = Nothing
    Exit Function
   
ErrorHandler:
    If Err.Number = -2147217865 Then isTableExist = False
    Err.Clear
    Resume Exit_Function
End Function

You might also like...

Comments

 NeverMalchik

Contribute

Why not write for us? Or you could submit an event or a user group in your area. Alternatively just tell us what you think!

Our tools

We've got automatic conversion tools to convert C# to VB.NET, VB.NET to C#. Also you can compress javascript and compress css and generate sql connection strings.

“Weeks of coding can save you hours of planning.”