Access MySQL databases using ODBC and ADO 2.7

Category:

Database

Type:

Classes

Difficulty:

Intermediate

Author: Anonymous

Version Compatibility: Visual Basic 6

More information:

The usual way to use this class is to call Connect after creating an instance of the class, then use Query2 to run queries (or Query3 if no data will be returned from queries). If an operation fails, check the LastError property to see what went wrong. Some functions in this class: Connect, connect to the MySQL database PutBlob, fill a blob field GetBlob, get data from a blob field PutFile, store a file in a blob field GetFile, retrieve a file from a blob field Query3, performs a query with no return data Query2, performs a query with return data MultiQuery2, performs multiple queries with return data MultiQuery, performs multiple queries with return data AddSlashes, adds slashes to a value so that it won't break query ResizeArray, resize a two dimensional array

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
' (None)

Code:

Option Explicit
' ------------------------------------------------------------------------------
' (c)2005 Jaron Lindow
' http://www.JaronLindow.com
'
' The purpose of this class is to assist in reading information from a MySQL
' database
'
' Data arrays are resized to (0 to Rows - 1, 0 to Cols - 1) when data is returned
'
' Required references:
' Microsoft ActiveX Data Objects 2.7 Library
' Microsoft ActiveX Data Objects Recordset 2.7 Library
' Microsoft ADO Ext. 2.7 for DDL and Security
'
' If the wrong references are used, queried data may be corrupted
' ------------------------------------------------------------------------------

' ------------------------------------------------------------------------------
Private Type TTable
  Name      As String
  Fields()  As String
  FieldHI   As Long
End Type

Private Type TRecord
  Fields()  As String
End Type

Private Type TBlob
  Length  As Integer
  Data()  As Byte
End Type

' ------------------------------------------------------------------------------
Private Declare Function GetTickCount Lib "kernel32" () As Long

' ------------------------------------------------------------------------------
Private ConString   As String ' Connection string

Private Tables()    As TTable
Private TableHI     As Long

Private LastErrStr  As String

' ------------------------------------------------------------------------------
Public Property Get LastError() As String
  LastError = LastErrStr
End Property

Public Property Let LastError(Value As String)
  LastErrStr = Value
End Property

Public Property Get TableCount() As Long
  TableCount = TableHI + 1
End Property

Public Property Get FieldCount(TableIndex As Long) As Long
  FieldCount = Tables(TableIndex).FieldHI + 1
End Property

' Returns the table index if found, -1 if not found
Public Property Get TableIndex(TableName As String) As Long
  Dim c As Long
  
  For c = 0 To TableHI
    If (Tables(c).Name = TableName) Then
      TableIndex = c
      Exit Sub
    End If
  Next c
  
  TableIndex = -1
End Property

Public Property Get Table(TableIndex As Long) As String
  Table = Tables(TableIndex).Name
End Property

Public Property Get Field(TableIndex As Long, FieldIndex As Long) As String
  Field = Tables(TableIndex).Fields(FieldIndex)
End Property

' ------------------------------------------------------------------------------
Public Function Connect(ByVal Server As String, ByVal Database As String, ByVal UserName As String, ByVal Password As String) As Boolean
  On Error GoTo E ' Remove for debugging
  ' -FUNCTION VARIABLES---------------------------------------------------------
  Dim Con       As ADODB.Connection ' ADO Connection object
 'Dim Rec       As ADODB.Recordset  ' ADO Recordset object
 'Dim Fld       As ADODB.Field      ' ADO Field object
  Dim Cat       As ADOX.Catalog     ' ADO Catalog object
  Dim Tbl       As ADOX.Table       ' ADO Table object
  
  Dim ShowTable As Boolean
  Dim c         As Long
  
  ' -VARIABLE INITIALIZATION----------------------------------------------------
  TableHI = -1
  
  ConString = GetConnectionString(Server, Database, UserName, Password)
  
  Set Con = New ADODB.Connection
 'Set Rec = New ADODB.Recordset
  Set Cat = New ADOX.Catalog
  
  ' -CONNECT TO THE DATABASE----------------------------------------------------
  Con.Open ConString          ' Open the Database
  Cat.ActiveConnection = Con  ' Connect the Catalog to the Connection
  
  ' -SCAN BASIC TABLE INFORMATION-----------------------------------------------
  For Each Tbl In Cat.Tables
    ' -DETERMINE WEITHER THE TABLE SHOULD BE SHOWN------------------------------
    Select Case Trim$(UCase(Tbl.Type))
      Case "TABLE":         ' Data table    - show
        ShowTable = True
      Case "SYSTEM TABLE":  ' System table  - hide
        ShowTable = False
      Case "VIEW":          ' Query table   - hide
        ShowTable = False
      Case Else:            ' Unknown table - show
        ShowTable = True
    End Select
    
    If (ShowTable) Then
      ' -GET FIELD NAMES FROM THE TABLE-----------------------------------------
      TableHI = TableHI + 1
      ReDim Preserve Tables(0 To TableHI)
      
      With Tables(TableHI)
        .Name = Tbl.Name
        .FieldHI = -1
      
        For c = 0 To Tbl.Columns.Count - 1
          DoEvents
          .FieldHI = .FieldHI + 1
          ReDim Preserve .Fields(0 To .FieldHI)
          .Fields(.FieldHI) = Tbl.Columns(c).Name
        Next c
      End With
    End If
  Next Tbl
  
  ' -CLEANUP--------------------------------------------------------------------
  Con.Close
  Set Tbl = Nothing
  Set Cat = Nothing
  Set Con = Nothing
  
  Connect = True
  Exit Function
  ' -ERROR HANDLING-------------------------------------------------------------
E:
  LastErrStr = Err.Description
  Debug.Print "Connect error: " & Err.Description
  Connect = False
End Function

' Saves data in the given array into a BLOB field
' SQLStatement: i.e. "SELECT RawData FROM SomeTable WHERE FileID='1'"
' FieldIndex:   i.e. 0
' Data():       i.e. (0, 1, 2, 3, 4, 5, 6, 7)
Public Function PutBlob(ByVal SQLStatement As String, ByVal FieldIndex As Long, ByRef Data() As Byte) As Boolean
  On Error GoTo E
  Dim Con     As ADODB.Connection
  Dim Rec     As ADODB.Recordset
  Dim Str     As ADODB.Stream
  
  Set Con = New ADODB.Connection
  Set Rec = New ADODB.Recordset
  Set Str = New ADODB.Stream
  
  Rec.CursorType = adOpenKeyset
  Rec.LockType = adLockOptimistic
  
  Str.Type = adTypeBinary
  
  Con.Open ConString
  Rec.Open SQLStatement, Con
  
  Rec(FieldIndex).AppendChunk Data
  
  Rec.Update
  
  Rec.Close
  Con.Close
  
  Set Str = Nothing
  Set Rec = Nothing
  Set Con = Nothing
  
  PutBlob = True
  Exit Function
E:
  PutBlob = False
  LastErrStr = Err.Description
  Debug.Print "PutBlob error: """ & Err.Description & """ when performing the query: """ & SQLStatement & """"
End Function

' Retrieves data from a BLOB field and returns in in an array
' SQLStatement: i.e. "SELECT RawData FROM SomeTable WHERE FileID='1'"
' FieldIndex:   i.e. 0
' Data_Out():   Byte array data will be returned in
Public Function GetBlob(ByVal SQLStatement As String, ByVal FieldIndex As Long, ByRef Data_Out() As Byte) As Boolean
  On Error GoTo E
  Dim Con     As ADODB.Connection
  Dim Rec     As ADODB.Recordset
  Dim Str     As ADODB.Stream
  Dim Length  As Long
  
  Set Con = New ADODB.Connection
  Set Rec = New ADODB.Recordset
  Set Str = New ADODB.Stream
  
  Rec.CursorType = adOpenKeyset
  Rec.LockType = adLockOptimistic
  
  Str.Type = adTypeBinary
  
  Con.Open ConString
  Rec.Open SQLStatement, Con
  
  Data_Out() = Rec(FieldIndex).GetChunk(Rec(FieldIndex).ActualSize)
  
  Rec.Close
  Con.Close
  
  Set Str = Nothing
  Set Rec = Nothing
  Set Con = Nothing
  
  GetBlob = True
  Exit Function
E:
  GetBlob = False
  LastErrStr = Err.Description
  Debug.Print "GetBlob error: """ & Err.Description & """ when performing the query: """ & SQLStatement & """"
End Function

' Reads a file and saves it to a BLOB field in an existing record
' SQLStatement: i.e. "SELECT FileData FROM SomeTable WHERE FileID='1'"
' FieldIndex:   i.e. 0 if the blob field FileData is the first field in the SQLStatement query
' FileName:     i.e. "C:\InputFile.dat"
Public Function PutFile(ByVal SQLStatement As String, ByVal FieldIndex As Long, ByVal FileName As String) As Boolean
  On Error GoTo E
  Dim Con As ADODB.Connection
  Dim Rec As ADODB.Recordset
  Dim Str As ADODB.Stream
  
  Set Con = New ADODB.Connection
  Set Rec = New ADODB.Recordset
  Set Str = New ADODB.Stream
  
  Rec.CursorType = adOpenKeyset
  Rec.LockType = adLockOptimistic
  
  Str.Type = adTypeBinary
  
  Con.Open ConString
  Rec.Open SQLStatement, Con
  
  Str.Open
  Str.LoadFromFile FileName
  
  Rec.Fields(FieldIndex) = Str.Read
  Rec.Update
  
  Str.Close
  Rec.Close
  Con.Close
  
  Set Str = Nothing
  Set Rec = Nothing
  Set Con = Nothing
  
  PutFile = True
  Exit Function
E:
  PutFile = False
  LastErrStr = Err.Description
  Debug.Print "PutFile error: """ & Err.Description & """ when performing the query: """ & SQLStatement & """ for the file """ & FileName & """"
End Function

' Retrieves data from a BLOB field and saves it as a file
' SQLStatement: i.e. "SELECT FileData FROM SomeTable WHERE FileID='1'"
' FieldIndex:   i.e. 0
' FileName:     i.e. "C:\NewFile.dat"
' Overwrite:    True to overwirte any existing file of the same name
Public Function GetFile(ByVal SQLStatement As String, ByVal FieldIndex As Long, ByVal FileName As String, Optional Overwrite As Boolean = True) As Boolean
  On Error GoTo E
  Dim Con As ADODB.Connection
  Dim Rec As ADODB.Recordset
  Dim Str As ADODB.Stream
  
  Set Con = New ADODB.Connection
  Set Rec = New ADODB.Recordset
  Set Str = New ADODB.Stream
  
  Rec.CursorType = adOpenKeyset
  Rec.LockType = adLockOptimistic
  
  Str.Type = adTypeBinary
  
  Con.Open ConString
  Rec.Open SQLStatement, Con
  
  Str.Open
  Str.Write Rec.Fields(FieldIndex)
  If (Overwrite) Then
    Str.SaveToFile FileName, adSaveCreateOverWrite
  Else
    Str.SaveToFile FileName, adSaveCreateNotExist
  End If
  
  Str.Close
  Rec.Close
  Con.Close
  
  Set Str = Nothing
  Set Rec = Nothing
  Set Con = Nothing
  
  GetFile = True
  Exit Function
E:
  GetFile = False
  LastErrStr = Err.Description
  Debug.Print "GetFile error: """ & Err.Description & """ when performing the query: """ & SQLStatement & """ for the file """ & FileName & """"
End Function

' Performs the given action but does not return data
' Returns True if there was no error, False if there was an error
Public Function Query3(ByVal SQLStatement As String) As Boolean
  On Error GoTo E
  ' -VARIABLES------------------------------------------------------------------
  Dim Con As ADODB.Connection
  Dim Rec As ADODB.Recordset
  
  ' -VARIABLE INITIALIZATION----------------------------------------------------
  Set Con = New ADODB.Connection
  Set Rec = New ADODB.Recordset
  
  ' -QUERY THE DATABASE---------------------------------------------------------
  Con.Open ConString
  Rec.Open SQLStatement, Con
  DoEvents
  
  ' -CLEANUP--------------------------------------------------------------------
  Con.Close
  
  Set Rec = Nothing
  Set Con = Nothing
  
  ' ----------------------------------------------------------------------------
  Query3 = True
  Exit Function
E:
  LastErrStr = Err.Description
  Debug.Print VBA.Date$ & " " & VBA.Time$ & " Query error: """ & Err.Description & """ when performing the query: """ & SQLStatement & """"
  Query3 = False
End Function

' The purpose of this function is to perform multiple SQL queries and append the results into a single output array
'
' Redimensions Fields to Fields(0 to FieldCount - 1) and  Data to Data(0 to Rows - 1, 0 to Cols - 1)
' TrimValues  = True to trim whitespace from the left and right of values
' Speed       = 100 = full speed.  50 = half speed.
Public Function MultiQuery2(ByRef SQLStatements As String, SQLStatementDelimiter As String, ByRef Fields_Out() As String, _
  ByRef FieldCount_Out As Long, ByRef Data_Out() As String, ByRef DataRows_Out As Long, ByRef DataCols_Out As Long, _
  Optional ByVal TrimValues As Boolean = False, Optional ByVal Speed As Double = 90) As Boolean
  ' -VARIABLES------------------------------------------------------------------
  Dim DlmLength   As Long
  Dim Query       As String
  Dim Queries()   As String
  Dim QueryCount  As Long
  Dim LPos        As Long
  Dim RPos        As Long
  
  ' -VARIABLE INITIALIZATION----------------------------------------------------
  If (SQLStatementDelimiter = "") Then
    SQLStatementDelimiter = vbCrLf
  End If
  DlmLength = Len(SQLStatementDelimiter)
  
  ' -FIND INDIVIDUAL SQL STATEMENTS---------------------------------------------
  LPos = 1
  Do
    RPos = InStr(LPos, SQLStatements, SQLStatementDelimiter)  ' Find the next delimiter position
    
    If (RPos > 0) Then                                        ' If the next delimiter position was found...
      Query = Trim$(Mid$(SQLStatements, LPos, RPos - LPos))   ' Grab a section of the string as the next query
    Else                                                      ' If the next delimiter position was not found...
      Query = Trim$(Mid$(SQLStatements, LPos))                ' Grab the rest of the string as the next query
    End If
    
    If (Query <> "") Then                                     ' If the next query is not blank...
      ' Add the next query to our list
      QueryCount = QueryCount + 1
      ReDim Preserve Queries(0 To QueryCount - 1)
      Queries(QueryCount - 1) = Query
    End If
    
    LPos = RPos + DlmLength + 1                               ' Set the next delimiter seek position
  Loop Until RPos = 0
  
  ' -PERFORM QUERIES------------------------------------------------------------
  If (QueryCount = 1) Then
    MultiQuery2 = Query2(Queries(0), Fields_Out(), FieldCount_Out, Data_Out(), DataRows_Out, DataCols_Out, TrimValues, Speed)
  Else
    MultiQuery2 = MultiQuery(Queries(), QueryCount, Fields_Out(), FieldCount_Out, Data_Out(), DataRows_Out, DataCols_Out, TrimValues, Speed)
  End If
End Function

' The purpose of this function is to perform multiple SQL queries and append the results into a single output array
'
' Redimensions Fields to Fields(0 to FieldCount - 1) and  Data to Data(0 to Rows - 1, 0 to Cols - 1)
' TrimValues  = True to trim whitespace from the left and right of values
' Speed       = 100 = full speed.  50 = half speed.
Public Function MultiQuery(ByRef SQLStatements() As String, SQLStatementCount As Long, ByRef Fields_Out() As String, _
  ByRef FieldCount_Out As Long, ByRef Data_Out() As String, ByRef DataRows_Out As Long, ByRef DataCols_Out As Long, _
  Optional ByVal TrimValues As Boolean = False, Optional ByVal Speed As Double = 90) As Boolean
  ' -VARIABLES------------------------------------------------------------------
  Dim AllOk         As Boolean
  Dim Fields()      As String
  Dim FieldCount    As Long
  Dim Data()        As String
  Dim Rows          As Long
  Dim Cols          As Long
  Dim q             As Long
  Dim r             As Long
  Dim c             As Long
  
  ' -VARIABLE INITIALIZIATION---------------------------------------------------
  AllOk = True
  
  ReDim Fields_Out(0 To 0)
  FieldCount_Out = 0
  ReDim Data_Out(0 To 0, 0 To 0)
  DataRows_Out = 0
  DataCols_Out = 0
  
  ' -PERFORM QUERIES------------------------------------------------------------
  ' For each query in the list...
  For q = 0 To SQLStatementCount - 1
    ' Perform the current query
    AllOk = AllOk And Query2(SQLStatements(q), Fields(), FieldCount, Data(), Rows, Cols, TrimValues, Speed)
    
    ' Add to the Field list if it is too small...
    If (FieldCount > FieldCount_Out) Then
      ReDim Preserve Fields_Out(0 To FieldCount - 1)
      For c = FieldCount_Out To FieldCount - 1
        Fields_Out(c) = Fields(c)
      Next c
      FieldCount_Out = FieldCount
    End If
    
    ' Expand the output array to accomodate the data retrieved in the last query
    Call ResizeArray(Data_Out(), DataRows_Out, DataCols_Out, DataRows_Out + Rows, Larger(DataCols_Out, Cols))
    
    ' Copy newly queried data into the output array
    For r = 0 To Rows - 1
      For c = 0 To Cols - 1
        Data_Out(DataRows_Out + r, c) = Data(r, c)
      Next c
    Next r
    DataRows_Out = DataRows_Out + Rows
    DataCols_Out = Larger(DataCols_Out, Cols)
  Next q
  
  ' ----------------------------------------------------------------------------
  MultiQuery = AllOk
End Function

' Redimensions Fields to Fields(0 to FieldCount - 1) and  Data to Data(0 to Rows - 1, 0 to Cols - 1)
' TrimValues  = True to trim whitespace from the left and right of values
' Speed       = 100 = full speed.  50 = half speed.
Public Function Query2(ByVal SQLStatement As String, ByRef Fields_Out() As String, ByRef FieldCount_Out As Long, _
  ByRef Data_Out() As String, ByRef DataRows_Out As Long, ByRef DataCols_Out As Long, _
  Optional ByVal TrimValues As Boolean = False, Optional ByVal Speed As Double = 90) As Boolean
  On Error GoTo E ' Remove for debugging
  ' -FUNCTION VARIABLES---------------------------------------------------------
  Dim Con             As ADODB.Connection ' ADO Connection object
  Dim Rec             As ADODB.Recordset  ' ADO Recordset object
  Dim Fld             As ADODB.Field      ' ADO Field object
 'Dim Str             As ADODB.Stream     ' ADO Stream object
 'Dim Cat             As ADOX.Catalog     ' ADO Catalog object
 'Dim Tbl             As ADOX.Table       ' ADO Table object
  
  Dim TempS()         As String
  Dim TempSHi         As Long
  Dim TempSUB         As Long
  
  Dim TmpRec()        As TRecord
  Dim TmpRecHi        As Long
  Dim TmpRecUB        As Long
  Dim TmpRecResizeBy  As Long
  Dim TmpValue        As String
  
  Dim Pos             As Long
  
  Dim Downtime        As Double ' Fraction of time to spend waiting
  Dim LastTime        As Long   ' Temporary storage of GetTickCount() values
  Dim WaitTime        As Long   ' Time to spend waiting in milliseconds
  
  Dim r               As Long
  Dim c               As Long
  
  ' Debug.Print SQLStatement ' Debugging code
  
  ' -VARIABLE INITIALIZATION----------------------------------------------------
  FieldCount_Out = 0
  DataRows_Out = 0
  DataCols_Out = 0

Set Con = New ADODB.Connection
  Set Rec = New ADODB.Recordset
 'Set Str = New ADODB.Stream
  
  TmpRecResizeBy = 100
  
  If (Speed > 100) Then Speed = 100
  If (Speed < 1) Then Speed = 1
  
  Downtime = (100 - Speed) / 100
  
  ' -QUERY THE DATABASE---------------------------------------------------------
  Con.Open ConString
  Rec.Open SQLStatement, Con
  DoEvents
  
  ' -RETRIEVE FIELD NAMES-------------------------------------------------------
  TempSHi = -1
  TempSUB = -1
  For Each Fld In Rec.Fields
    TempSHi = TempSHi + 1
    If (TempSHi > TempSUB) Then
      TempSUB = TempSHi + 10
      ReDim Preserve TempS(TempSUB)
    End If
    TempS(TempSHi) = Fld.Name
  Next Fld
  
  ' -PUT THE FIELD NAMES IN AN OUTPUT ARRAY-------------------------------------
  FieldCount_Out = TempSHi + 1
  If (TempSHi >= 0) Then
    ReDim Fields_Out(TempSHi)
    
    If (TrimValues) Then
      For c = 0 To TempSHi
        Fields_Out(c) = Trim$(TempS(c))
      Next c
    Else
      For c = 0 To TempSHi
        Fields_Out(c) = TempS(c)
      Next c
    End If
  End If
  
  ' -RETRIEVE FIELD VALUES------------------------------------------------------
  LastTime = GetTickCount() ' Needed to figure out delay value
  
  TmpRecHi = -1
  TmpRecUB = -1
  If (FieldCount_Out > 0 And Rec.EOF = False) Then
    Do
      TmpRecHi = TmpRecHi + 1
      
      ' -PAUSE A CERTIAN PERCENT OF THE TIME TO PREVENT BOGGING THE SERVER DOWN-
      If (TmpRecHi Mod 100 = 0) Then
        DoEvents
        
        If (GetTickCount() - LastTime > 1000) Then
          WaitTime = (GetTickCount() - LastTime) * Downtime
          Pause WaitTime
          LastTime = GetTickCount()
        End If
      End If
      
      ' -MAKE ROOM FOR NEW RECORDS----------------------------------------------
      If (TmpRecHi > TmpRecUB) Then
        TmpRecResizeBy = TmpRecResizeBy * 2 + 1
        TmpRecUB = TmpRecHi + TmpRecResizeBy
        ReDim Preserve TmpRec(TmpRecUB)
        
        For c = TmpRecHi To TmpRecUB
          ReDim TmpRec(c).Fields(FieldCount_Out - 1)
        Next c
      End If
      
      ' -PUT RECORD INFORMATION IN THE TEMPORARY ARRAY--------------------------
      For c = 0 To FieldCount_Out - 1
        If (Rec.Fields(c).ActualSize > 0) Then
          TmpValue = GetFieldSafe(Rec, c)
          
          ' Reformat Date or Time fields
          Select Case Rec.Fields(c).Type
            Case ADODB.DataTypeEnum.adDate, ADODB.DataTypeEnum.adDBDate:  ' Date
              TmpValue = FormatDate(TmpValue, "YYYY-MM-DD")
            Case 135:                                                     ' DateTime
              TmpValue = FormatDate(TmpValue, "YYYY-MM-DD") & " " & FormatTime(TmpValue, "HH:MM:SS")
            Case ADODB.DataTypeEnum.adDBTime:                             ' Time
              TmpValue = FormatTime(TmpValue, "HH:MM:SS")
          End Select
          
          TmpRec(TmpRecHi).Fields(c) = TmpValue
        End If
      Next c
      
      Rec.MoveNext
    Loop Until Rec.EOF
  End If
  
  ' -COPY FIELD VALUES TO AN OUTPUT ARRAY---------------------------------------
  DataRows_Out = TmpRecHi + 1
  DataCols_Out = FieldCount_Out
  
  If (DataRows_Out > 0 And DataCols_Out > 0) Then
    ReDim Data_Out(0 To DataRows_Out - 1, 0 To DataCols_Out - 1)
    
    If (TrimValues) Then
      For r = 0 To DataRows_Out - 1
        For c = 0 To DataCols_Out - 1
          Data_Out(r, c) = Trim$(TmpRec(r).Fields(c))
        Next c
      Next r
    Else
      For r = 0 To DataRows_Out - 1
        For c = 0 To DataCols_Out - 1
          Data_Out(r, c) = TmpRec(r).Fields(c)
        Next c
      Next r
    End If
  End If
  
  ' -CLEANUP--------------------------------------------------------------------
  Rec.Close
  Con.Close
  Set Rec = Nothing
  Set Con = Nothing
  
  Query2 = True
  Exit Function
  ' ----------------------------------------------------------------------------
E:
  LastErrStr = Err.Description
  
  Debug.Print VBA.Date$ & " " & VBA.Time$ & " Query error: """ & Err.Description & """ when performing the query: """ & SQLStatement & """"
  If (Not Con Is Nothing) Then
    Debug.Print "Connection errors: "
    For c = 0 To Con.Errors.Count - 1
      Debug.Print Con.Errors.Item(c).Description
    Next c
  End If
  
  Query2 = False
End Function

' Addes slashes to a value so that it won't cause the query to choke
Public Function AddSlashes(Value As String) As String
  AddSlashes = VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(Value, _
    "\", "\\"), _
    "'", "\'"), _
    "`", "\`"), _
    vbLf, "\n"), _
    vbTab, "\t"), _
    vbCr, "\r"), _
    Chr$(8), "\b")
End Function

Public Sub ResizeArray(ByRef Data() As String, OldRows As Long, OldCols As Long, NewRows As Long, NewCols As Long)
  Dim NewData() As String
  Dim r         As Long
  Dim c         As Long
  
  ' Copy data to a temporary array
  ReDim NewData(0 To Larger(NewRows, 0), 0 To Larger(NewCols, 0))
  For r = 0 To Smaller(OldRows, NewRows)
    For c = 0 To Smaller(OldCols, NewCols)
      NewData(r, c) = Data(r, c)
    Next c
  Next r
  
  ' Copy data back to the source array
  ReDim Data(0 To Larger(NewRows, 0), 0 To Larger(NewCols, 0))
  For r = 0 To Smaller(OldRows, NewRows)
    For c = 0 To Smaller(OldCols, NewCols)
      Data(r, c) = NewData(r, c)
    Next c
  Next r
End Sub

' ------------------------------------------------------------------------------
Private Function Larger(L1 As Long, L2 As Long) As Long
  If (L1 > L2) Then
    Larger = L1
  Else
    Larger = L2
  End If
End Function

Private Function Smaller(L1 As Long, L2 As Long) As Long
  If (L1 < L2) Then
    Smaller = L1
  Else
    Smaller = L2
  End If
End Function

' ------------------------------------------------------------------------------
Private Function GetFieldSafe(ByRef Rec As ADODB.Recordset, FieldIndex As Long) As String
  On Error GoTo E
  GetFieldSafe = Rec.Fields(FieldIndex).Value
  Exit Function
E:
  GetFieldSafe = ""
End Function
  
Private Function GetConnectionString(ByRef Server As String, ByRef Database As String, ByRef UserName As String, ByRef Password As String) As String
  GetConnectionString = _
    "Provider=MSDASQL.1;" & _
    "Persist Security Info=False;" & _
    "User ID=" & UserName & ";" & _
    "Extended Properties=""" & _
    "DRIVER={MySQL ODBC 3.51 Driver};" & _
    "DATABASE=" & Database & ";" & _
    "SERVER=" & Server & ";" & _
    "UID=" & UserName & ";" & _
    "PASSWORD=" & Password & ";"";" & _
    "OPTION=16427;"
    
    ' Note: "OPTION=16427;" added to allow BLOB operations
End Function

Private Function FormatDate(ByVal DateIn As String, Optional Format As String = "YYYYMMDD") As String
  On Error Resume Next
  Dim s(0 To 3) As String   ' (YYYY, YY, MM, DD)
  Dim c         As Integer
  
  s(0) = VBA.Year(DateIn)     ' YYYY
  s(1) = VBA.Right$(s(0), 2)  ' YY
  s(2) = VBA.Month(DateIn)    ' MM
  s(3) = VBA.Day(DateIn)      ' DD
  
  For c = 1 To 3
    If (Len(s(c)) < 2) Then s(c) = "0" & s(c)
  Next c
  
  FormatDate = VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(Format, _
    "YYYY", s(0), , , vbTextCompare), _
    "YY", s(1), , , vbTextCompare), _
    "MM", s(2), , , vbTextCompare), _
    "DD", s(3), , , vbTextCompare)
End Function

Private Function FormatTime(ByVal TimeIn As String, Optional Format As String = "HH:MM:SS") As String
  On Error Resume Next
  Dim s(0 To 2) As String   ' (HH, MM, SS)
  Dim c         As Integer
  
  s(0) = VBA.Hour(TimeIn)
  s(1) = VBA.Minute(TimeIn)
  s(2) = VBA.Second(TimeIn)
  
  For c = 0 To 2
    If (Len(s(c)) < 2) Then s(c) = "0" & s(c)
  Next c
  
  FormatTime = VBA.Replace(VBA.Replace(VBA.Replace(Format, _
    "HH", s(0), , , vbTextCompare), _
    "MM", s(1), , , vbTextCompare), _
    "SS", s(2), , , vbTextCompare)
End Function

' ------------------------------------------------------------------------------
Private Sub Pause(Milliseconds As Long)
  Dim EndTime As Long
  
  EndTime = GetTickCount() + Milliseconds
  Do
    DoEvents
  Loop Until GetTickCount() >= EndTime
End Sub

' ------------------------------------------------------------------------------
Private Sub Class_Initialize()
  TableHI = -1
End Sub

Private Sub Class_Terminate()
  '
End Sub

' ------------------------------------------------------------------------------
' ------------------------------------------------------------------------------