Code Snippets

Database_AddResults

Public Sub Database_AddResults( _
         ByVal sTableName As String, _
ParamArray vColumnsValues() As Variant)

Dim icolumnnumber As Integer
Dim scolumnname As String
Dim scolumnnameconcat As String
Dim scolumnvalue As String
Dim scolumnvalueconcat As String
Dim ssqltemp As String

   On Error GoTo ErrorHandler

'   If vColumnsValues = Nothing Then Exit Sub

   For icolumnnumber = 1 To (UBound(vColumnsValues) + 1) / 2
      scolumnname = vColumnsValues(2 * (icolumnnumber - 1))
      scolumnvalue = vColumnsValues(2 * (icolumnnumber - 1) + 1)

      scolumnnameconcat = scolumnnameconcat & scolumnname & ","
      scolumnvalueconcat = scolumnvalueconcat & """" & scolumnvalue & """" & ","

   Next icolumnnumber

   ssqltemp = "INSERT INTO " & sTableName & _
              " (" & Left$(scolumnnameconcat, Len(scolumnnameconcat) - 1) & ") " & _
              "VALUES (" & Left$(scolumnvalueconcat, Len(scolumnvalueconcat) - 1) & ")"

   gsSQLQuery = ssqltemp
   Call Database_SQLRunCode(False, False)
   If gbDEBUG = False Then Exit Sub

ErrorHandler:
    Call Error_Handle("Str_CharsReplace", msMODULENAME, 1, _
        "INSERT the array of data into the database ??")
End Sub

Database_ContainsData

Public Function Database_ContainsData( _
         ByRef dbADORecordset As ADODB.Recordset) _
         As Boolean

   On Error GoTo ErrorHandler

   dbADORecordset.MoveFirst
   Database_ContainsData = True
   Exit Function

ErrorHandler:
   Database_ContainsData = False
End Function

Database_NoOfRows

Public Function Database_NoOfRows( _
         ByRef dbADORecordset As ADODB.Recordset) _
         As Long

Dim lcount As Long

   On Error GoTo ErrorHandler

   If Database_ContainsData(dbADORecordset) = False Then
      Database_NoOFRows = -1
      Exit Function
   Else
      Do Until dbADORecordset.EOF = True
         dbADORecordset.MoveNext
         lcount = lcount + 1
      Loop
      Database_NoOFRows = lcount
   End If
   Exit Function

ErrorHandler:
   Call Error_Handle(Err.Number & " " & Err.Description, "Database_NoOfRows")
End Function

Database_ResultsToArrayMulti

Public Function Database_ResultsToArrayMulti( _
         ByVal sArrayName As String, _
         ByRef vArrayName As Variant, _
Optional ByVal bIncludeFields As Boolean = True, _
Optional ByVal iNoOfColumns As Integer = -1, _
Optional ByVal iPopulateCol As Integer = -1) _
         As Boolean

Dim ltotalrecords As Long
Dim lrownumber As Long
Dim lrecordcounter As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler

   Set vArrayName = Nothing
   Database_ResultsToArrayMulti = False
   ltotalrecords = gobjADORecordSet.RecordCount

   If (ltotalrecords > 0) Then
      Database_ResultsToArrayMulti = True
      If bIncludeFields = True Then 
         ltotalrecords = ltotalrecords + 1
      End If 
      
      If iNoOfColumns = -1 Then 
         ReDim vArrayName(gobjADORecordSet.Fields.Count, ltotalrecords)
      End If
      If iNoOfColumns > 0 Then 
         ReDim vArrayName(iNoOfColumns - 1, ltotalrecords - 1)
      End If
      
      If gobjADORecordSet.State = ADODB.adStateOpen Then
         If bIncludeFields = True Then
            For ifieldnumber = 0 To gobjADORecordSet.Fields.Count - 1
               vArrayName(ifieldnumber, 0) = _
                                          gobjADORecordSet.Fields(ifieldnumber).Name
            Next ifieldnumber
         End If
         For lrownumber = (ltotalrecords - gobjADORecordSet.RecordCount) To ltotalrecords - 1
            For ifieldnumber = 0 To gobjADORecordSet.Fields.Count - 1
               If iNoOfColumns > 0 Then
                  If IsNull(gobjADORecordSet.Fields(ifieldnumber).Value) = True Then
                     If iPopulateCol = -1 Then 
                        vArrayName(ifieldnumber, lrownumber) = ""
                     End If
                     If iPopulateCol > 0 Then 
                        vArrayName(iPopulateCol, lrownumber) = ""
                     End If
                  Else
                     If iPopulateCol = -1 Then
                        vArrayName(ifieldnumber, lrownumber) = _
                                       CStr(gobjADORecordSet.Fields(ifieldnumber).Value)
                     End If
                     If iPopulateCol > 0 Then
                        vArrayName(iPopulateCol, lrownumber) = _
                                       CStr(gobjADORecordSet.Fields(ifieldnumber).Value)
                     End If
                  End If
               End If
            Next ifieldnumber
            gobjADORecordSet.MoveNext
         Next lrownumber
      End If
   End If
   Set gobjADORecordSet = Nothing

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Call Error_Handle("Database_ResultsToArray", msMODULENAME, 1, _
        "transfer the results of the database recordset into the array " & _
        """" & sArrayName & """")
End Function

Database_ResultsToArraySingle

Public Sub Database_ResultsToArraySingle( _
         ByVal sArrayName As String, _
         ByVal vArrayName As Variant, _
Optional ByVal bIncludeField As Boolean = False)

Dim ltotalrecords As Long
Dim lrownumber As Long
Dim lrecordcounter As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler

   Set vArrayName = Nothing
   ltotalrecords = gobjADORecordSet.RecordCount
   If ltotalrecords > 0 Then
      If bIncludeField = True Then ltotalrecords = ltotalrecords + 1
      
      ReDim vArrayName(ltotalrecords - 1)
      
      If gobjADORecordSet.State = ADODB.adStateOpen Then
         If bIncludeField = True Then
            vArrayName(0) = gobjADORecordSet.Fields(ifieldnumber).Name
         End If
         For lrownumber = (ltotalrecords - gobjADORecordSet.RecordCount) + 1 To ltotalrecords
            If IsNull(gobjADORecordSet.Fields(0).Value) = True Then
               vArrayName(lrownumber - 1) = ""
            Else
               vArrayName(lrownumber - 1) = _
                                 CStr(gobjADORecordSet.Fields(0).Value)
            End If
            gobjADORecordSet.MoveNext
         Next lrownumber
      End If
   End If
   Set gobjADORecordSet = Nothing

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_ResultsToArraySingle", msMODULENAME, 1, _
        "transfer the results of the database recordset into the array " & _
        """" & sArrayName & """")
End Sub

Database_ResultsToListComboBox

Transfers the results of the database recordset into an listbox or combobox.

Public Sub Database_ResultsToListComboBox( _
         ByVal ctlBoxName As Control)

Dim lrownumber As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler

   If (gobjADORecordSet.RecordCount > 0) Then
      
      If (gobjADORecordSet.State = ADODB.adStateOpen) Then
                  
         For lrownumber = 1 To gobjADORecordSet.RecordCount
         
            ctlBoxName.AddItem

            For ifieldnumber = 1 To gobjADORecordSet.Fields.Count
            
               If IsNull(gobjADORecordSet.Fields(ifieldnumber - 1).Value) = True Then
                  ctlBoxName.Column(ifieldnumber - 1, ctlBoxName.ListCount - 1) = ""
               Else
                  ctlBoxName.Column(ifieldnumber - 1, ctlBoxName.ListCount - 1) = _
                     CStr(gobjADORecordSet.Fields(ifieldnumber - 1).Value)
               End If
            Next ifieldnumber
            gobjADORecordSet.MoveNext
         Next lrownumber
      End If
   End If
   Set gobjADORecordSet = Nothing

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_ResultsToListComboBox", msMODULENAME, 1, _
         "")
End Sub

Database_ResultsToStr

Transfers the results of the database recordset into a string concatenation.

Public Sub Database_ResultsToStr()

   On Error GoTo ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_ResultsToStr", msMODULENAME, 1, _
         "")
End Sub

Database_ResultsToTextFile

Transfers the results of the database recordset into a text file.

Public Sub Database_ResultsToTextFile()

   On Error GoTo ErrorHandler

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_ResultsToTextFile", msMODULENAME, 1, _
         "")
End Sub

Database_SQLParameterDeclare

Declares a parameter for calling a database stored procedure.

Public Sub Database_SQLParameterDeclare( _
         ByVal iType As Integer, _
         ByVal iDirection As Integer, _
Optional ByVal iSize As Integer = 0, _
Optional ByVal sValue As Variant = "??", _
Optional ByVal sParameterName As String = "ParamName")

On Error GoTo ErrorHandler

   Set gobjADOParameter = New ADODB.Parameter
   If sValue <> "??" Then
      Set gobjADOParameter = gobjADOCommand.CreateParameter(sParameterName, _
                              iType, iDirection, iSize, sValue)
   End If
   If sValue = "??" Then
      Set gobjADOParameter = gobjADOCommand.CreateParameter(sParameterName, _
                              iType, iDirection, iSize)
   End If
                           
   gobjADOCommand.Parameters.Append dbADOParameter
   Set gobjADOParameter = Nothing

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_SQLParameterDeclare", msMODULENAME, 1, _
        "declare the following paramter for the stored procedure" & vbCrLf & _
        "Type:= " & iType & " Direction:= " & iDirection & " Size:= " & iSize)
End Sub

Database_SQLProcFuncCall

Executes a database stored procedure. If the stored procedure returns a value then this is returned.

Public Function Database_SQLProcFuncCall( _
         ByVal sProcFuncName As String, _
Optional ByVal bReturnValue As Boolean = False, _
Optional ByVal bRowReturning As Boolean = False, _
Optional ByVal iReturnType As Integer, _
Optional ByVal iReturnSize As Integer, _
Optional ByVal sVar1Value As Variant = "", _
Optional ByVal iVar1Type As Integer = 1, _
Optional ByVal sVar2Value As Variant = "", _
Optional ByVal iVar2Type As Integer = 1, _
Optional ByVal sVar3Value As Variant = "", _
Optional ByVal iVar3Type As Integer = 1, _
Optional ByVal sVar4Value As Variant = "", _
Optional ByVal iVar4Type As Integer = 1, _
Optional ByVal sVar5Value As Variant = "", _
Optional ByVal iVar5Type As Integer = 1, _
Optional ByVal sVar6Value As Variant = "", _
Optional ByVal iVar6Type As Integer = 1) _
         As Variant

   On Error GoTo ErrorHandler

   Set dbADOCommand = New ADODB.Command
   Set dbADOCommand.ActiveConnection = dbADOConnect
   dbADOCommand.Name = "CommandName"
   dbADOCommand.CommandText = sProcFuncName
   dbADOCommand.CommandType = adCmdStoredProc

   If bReturnValue = True Then
      dbADOCommand.Parameters.Append _
           dbADOCommand.CreateParameter("ReturnName", _
                                        iReturnType, _
                                        adParamReturnValue, _
                                        iReturnSize)
   End If
   
   If sVar1Value <> "" Then
      Call DataBase_SQLParameterDeclare(iVar1Type, adParamInput, sVar1Value, 10)
   End If
   If sVar2Value <> "" Then
      Call DataBase_SQLParameterDeclare(iVar2Type, adParamInput, sVar2Value, 10)
   End If
   If sVar3Value <> "" Then
      Call DataBase_SQLParameterDeclare(iVar3Type, adParamInput, sVar3Value, 10)
   End If
   If sVar4Value <> "" Then
      Call DataBase_SQLParameterDeclare(iVar4Type, adParamInput, sVar4Value, 10)
   End If
   If sVar5Value <> "" Then
      Call DataBase_SQLParameterDeclare(iVar5Type, adParamInput, sVar5Value, 10)
   End If
   If sVar6Value <> "" Then
      Call DataBase_SQLParameterDeclare(iVar6Type, adParamInput, sVar6Value, 10)
   End If
   
   Set dbADORecordSet = New ADODB.Recordset
   Set dbADORecordSet = dbADOCommand.Execute
   'error here - the procedure or function may not be in the declaration of the PL SQL
      
   If bReturnValue = True Then
      DataBase_SQLProcFuncCall = dbADOCommand("ReturnName")
   End If
   
   Set dbADOCommand = Nothing

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Set dbADOCommand = Nothing
   Call Error_Handle("Database_SQLProcFuncCall", msMODULENAME, 1, _
        "execute the database stored procedure and obtain the recordset value")
End Function

Database_SQLProcFuncDeclare

Public Sub Database_SQLProcFuncDeclare( _
         ByVal sProcFuncName As String, _
Optional ByVal bReturnValue As Boolean = False, _
Optional ByVal bRowReturning As Boolean = False, _
Optional ByVal iReturnType As Integer, _
Optional ByVal iReturnSize As Integer)

On Error GoTo AnError

   Set gobjADOCommand = New ADODB.Command
   Set gobjADOCommand.ActiveConnection = gobjADOConnect
   gobjADOCommand.CommandText = sProcFuncName
   gobjADOCommand.CommandType = adCmdStoredProc
   
   If bReturnValue = True Then
      gobjADOCommand.Parameters.Append _
         gobjADOCommand.CreateParameter("ReturnName", iReturnType, _
                                        adParamReturnValue, iReturnSize)
   
   End If
   
   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_SQLProcFuncDeclare", msMODULENAME, 1,
        Err.Number & " " & Err.Description)
End Sub

Database_SQLProcFuncExecute

Public Sub Database_SQLProcFuncExecute( _
Optional ByVal bReturnValue As Boolean = False, _
Optional ByVal sOutParameter1 As String = "", _
Optional ByVal vReturnValue1 As Variant, _
Optional ByVal sOutParameter2 As String = "", _
Optional ByVal vReturnValue2 As Variant, _
Optional ByVal sOutParameter3 As String = "", _
Optional ByVal vReturnValue3 As Variant)

On Error GoTo ErrorHandler

   Set gobjADORecordSet = New ADODB.Recordset
   Set gobjADORecordSet = gobjADOCommand.Execute

'error here - the procedure of function may not be in the declaration of the PL SQL
 
   If bReturnValue = True Then
      If Len(sOutParameter1) > 0 Then
         If Not IsNull(gobjADOCommand(sOutParameter1).Value) Then
            vReturnValue1 = gobjADOCommand(sOutParameter1).Value
         End If
      End If
      If Len(sOutParameter2) > 0 Then
         If Not IsNull(gobjADOCommand(sOutParameter2).Value) Then
            vReturnValue2 = gobjADOCommand(sOutParameter2).Value
         End If
      End If
      If Len(sOutParameter3) > 0 Then
         If Not IsNull(gobjADOCommand(sOutParameter3).Value) Then
            vReturnValue3 = gobjADOCommand(sOutParameter3).Value
         End If
      End If
   End If

   Set gobjADOCommand = Nothing
   
   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_SQLProcFuncExecute", msMODULENAME, 1,
        Err.Number & " " & Err.Description)
End Sub

Database_SQLRecordOutputResults

Public Function DataBase_SQLRecordOutputResults( _
         ByVal iColFirst As Integer, _
         ByVal lRowFirst As Long, _
Optional ByVal bIncludeFields As Boolean = True) _
         As Long

Dim lRowNumber As Long
Dim lRowLast As Long
Dim icolumnnumber As Integer
Dim lrecordcounter As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler

   lRowNumber = lRowFirst
   If dbADORecordset.state = ADODB.adStateOpen Then
      icolumnnumber = iColFirst 
      If bIncludeFields = True Then
         For ifieldnumber = 1 To dbADORecordset.Fields.Count
            ActiveSheet.Cells(lRowNumber, icolumnnumber).Value = _
                              CStr(dbADORecordset.Fields(ifieldnumber - 1).Name)
            icolumnnumber = icolumnnumber + 1
         Next ifieldnumber
         lRowNumber = lRowNumber + 1
      End If
      While Not dbADORecordset.EOF
         icolumnnumber = iColFirst 
         For ifieldnumber = 1 To dbADORecordset.Fields.Count
          
            If IsNull(dbADORecordset.Fields(ifieldnumber - 1).Value) = False Then
         
               'then it must be a date as a string format
               If IsDate(dbADORecordset.Fields(ifieldnumber - 1).Value) = True Then
               
                     ActiveSheet.Cells(lRowNumber, icolumnnumber).Value = _
                                       DateSerial(DatePart("yyyy", CDate(dbADORecordset.Fields(ifieldnumber - 1).Value)), _
                                                  DatePart("m", CDate(dbADORecordset.Fields(ifieldnumber - 1).Value)), _
                                                  DatePart("d", CDate(dbADORecordset.Fields(ifieldnumber - 1).Value)))
                                                  
               Else
                  If IsNumeric(CStr(dbADORecordset.Fields(ifieldnumber - 1).Value)) = False Then
                     ActiveSheet.Cells(lRowNumber, icolumnnumber).NumberFormat = "@"
                     ActiveSheet.Cells(lRowNumber, icolumnnumber).Value = _
                                       Trim(CStr(dbADORecordset.Fields(ifieldnumber - 1).Value))
                  Else
                     ActiveSheet.Cells(lRowNumber, icolumnnumber).Value = _
                                       Trim(CStr(dbADORecordset.Fields(ifieldnumber - 1).Value))
                  End If
               End If
            
            End If
            
            icolumnnumber = icolumnnumber + 1
         Next ifieldnumber
         dbADORecordset.MoveNext
         lRowNumber = lRowNumber + 1
      Wend
   End If
   
   'minus one to return the last row that contains data
   lRowLast = lRowNumber - 1
   
   'plus one at the end to get the actual number of rows from the difference
   lRowFirst = (lRowLast - lRowFirst) + 1
   Set dbADORecordset = Nothing
   Exit Function
   
ErrorHandler:
   Call Error_Handle(Err.Number & " - " & Err.Description, "DataBase_SQLRecordOutputResults")
End Function

Database_SQLReturnArray

Public Function DataBase_SQLReturnArray( _
         ByVal iColFirst As Integer, _
         ByVal lRowFirst As Long, _
Optional ByVal bIncludeFields As Boolean = True) _
         As Variant

Dim vaTemporary As Variant
Dim lRowNumber As Long
Dim lRowLast As Long
Dim icolumnnumber As Integer
Dim lrecordcounter As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler

   lRowNumber = lRowFirst
   If dbADORecordset.state = ADODB.adStateOpen Then
      
      If lRowNumber Mod 100 = 0 Then
         ReDim Preserve vaTemporary(dbADORecordset.Fields.Count, lRowNumber)
      End If
      
      icolumnnumber = iColFirst
      If bIncludeFields = True Then
         For ifieldnumber = 1 To dbADORecordset.Fields.Count
            vaTemporary(lRowNumber, icolumnnumber) = _
                              CStr(dbADORecordset.Fields(ifieldnumber - 1).Name)
            icolumnnumber = icolumnnumber + 1
         Next ifieldnumber
         lRowNumber = lRowNumber + 1
      End If
      
      
      While Not dbADORecordset.EOF
         icolumnnumber = iColFirst
         
         If lRowNumber Mod 100 = 0 Then
            ReDim Preserve vaTemporary(dbADORecordset.Fields.Count, lRowNumber)
         End If
         
         For ifieldnumber = 1 To dbADORecordset.Fields.Count
          
            If IsNull(dbADORecordset.Fields(ifieldnumber - 1).Value) = False Then
         
               'then it must be a date as a string format
               If IsDate(dbADORecordset.Fields(ifieldnumber - 1).Value) = True Then
                     vaTemporary(lRowNumber, icolumnnumber) = _
                                       DateSerial(DatePart("yyyy", CDate(dbADORecordset.Fields(ifieldnumber - 1).Value)), _
                                                  DatePart("m", CDate(dbADORecordset.Fields(ifieldnumber - 1).Value)), _
                                                  DatePart("d", CDate(dbADORecordset.Fields(ifieldnumber - 1).Value)))
                                                  
               Else
                  If IsNumeric(CStr(dbADORecordset.Fields(ifieldnumber - 1).Value)) = False Then
                     vaTemporary(lRowNumber, icolumnnumber) = _
                                       Trim(CStr(dbADORecordset.Fields(ifieldnumber - 1).Value))
                  Else
                     vaTemporary(lRowNumber, icolumnnumber) = _
                                       Trim(CStr(dbADORecordset.Fields(ifieldnumber - 1).Value))
                  End If
               End If
            
            End If
            
            icolumnnumber = icolumnnumber + 1
         Next ifieldnumber
         dbADORecordset.MoveNext
         lRowNumber = lRowNumber + 1
      Wend
   End If
      
   DataBase_SQLReturnArray = vaTemporary
   
   Set dbADORecordset = Nothing
   Exit Function
   
ErrorHandler:
   Call Error_Handle(Err.Number & " - " & Err.Description, "DataBase_SQLRecordOutputResults")
End Function

Database_SQLRunCode

Executes a database SQL statement Sometimes a constraint is violated ??.

Public Function Database_SQLRunCode( _
Optional ByVal bReturnRecordSet As Boolean = False, _
Optional ByVal bReturnValue As Boolean = False) _
         As Variant

   On Error GoTo ErrorHandler

   Set gobjADOCommand = New ADODB.Command
   gobjADOCommand.CommandText = gsSQLQuery
   gobjADOCommand.CommandType = adCmdText
   gobjADOCommand.ActiveConnection = gobjADOConnect

   If (bReturnRecordSet = True Or bReturnValue = True) Then
      Set gobjADORecordSet = New ADODB.Recordset
      Set gobjADORecordSet = gobjADOCommand.Execute
      If bReturnValue = True Then
         If gobjADORecordSet.EOF = True Then
            Database_SQLRunCode = "Empty"
         Else
            Database_SQLRunCode = gobjADORecordSet.Fields(0).Value
         End If
         gobjADORecordSet.Close
      Else
         If gobjADORecordSet.EOF = True Then Database_SQLRunCode = "Empty"
      End If
   End If
   If (bReturnRecordSet = False And bReturnValue = False) Then
      gobjADOCommand.Execute
   End If

   If gbDEBUG = False Then Exit Function
ErrorHandler:
   Set gobjADOCommand = Nothing
   Database_SQLRunCode = "Error"

   Call Error_Handle("Database_SQLRunCode", msMODULENAME, 1, _
        "execute the following SQL code and obtain the recordset" & _
        vbCrLf & vbCrLf & gsSQLQuery & vbCrLf & vbCrLf & _
        """" & Err.Number & """ """ & Err.Description & """")

'only include the comment "obtain a recordset if the Boolean variable is passed in
End Function

Database_SQLToArray

Public Function DataBase_SQLToArray( _
         ByVal objADORecordSet As ADODB.Recordset, _
Optional ByVal bIncludeFieldNames As Boolean = False, _
Optional ByVal lArrayColFirst As Long = 0, _
Optional ByVal lArrayRowFirst As Long = 0) _
         As Variant

Dim vaTemporary As Variant
Dim larrayrowno As Long
Dim larraycolno As Long
Dim lrecordcounter As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler

   larrayrowno = 0
   If objADORecordSet.state = ADODB.adStateOpen Then
      
      If larrayrowno Mod 100 = 0 Then
         ReDim vaTemporary(objADORecordSet.Fields.Count - 1, larrayrowno + 100)
      End If
      
      larraycolno = 0
      If bIncludeFieldNames = True Then
         For ifieldnumber = 1 To objADORecordSet.Fields.Count
            vaTemporary(larraycolno, larrayrowno) = CStr(objADORecordSet.Fields(ifieldnumber - 1).Name)
            
            larraycolno = larraycolno + 1
         Next ifieldnumber
         
         larrayrowno = larrayrowno + 1
      End If
      
      While Not objADORecordSet.EOF
         larraycolno = 0
         
         If larrayrowno Mod 100 = 0 Then
            ReDim Preserve vaTemporary(objADORecordSet.Fields.Count - 1, larrayrowno + 100)
         End If
         
         For ifieldnumber = 1 To objADORecordSet.Fields.Count
          
            If IsNull(objADORecordSet.Fields(ifieldnumber - 1).Value) = False Then

               vaTemporary(larraycolno, larrayrowno) = Trim(CStr(objADORecordSet.Fields(ifieldnumber - 1).Value))


'               'then it must be a date as a string format
'               If IsDate(objADORecordSet.Fields(ifieldnumber - 1).Value) = True Then
'                     vaTemporary(larrayrowno, larraycolno) = _
'                                       DateSerial(DatePart("yyyy", CDate(objADORecordSet.Fields(ifieldnumber - 1).Value)), _
'                                                  DatePart("m", CDate(objADORecordSet.Fields(ifieldnumber - 1).Value)), _
'                                                  DatePart("d", CDate(objADORecordSet.Fields(ifieldnumber - 1).Value)))
'
'               Else
'                  If IsNumeric(CStr(objADORecordSet.Fields(ifieldnumber - 1).Value)) = False Then
'                     vaTemporary(larrayrowno, larraycolno) = _
'                                       Trim(CStr(objADORecordSet.Fields(ifieldnumber - 1).Value))
'                  Else
'                     vaTemporary(larrayrowno, larraycolno) = _
'                                       Trim(CStr(objADORecordSet.Fields(ifieldnumber - 1).Value))
'                  End If
'               End If
            
            End If
            
            larraycolno = larraycolno + 1
         Next ifieldnumber
         
         objADORecordSet.MoveNext
         larrayrowno = larrayrowno + 1
      Wend
   End If
      
   ReDim Preserve vaTemporary(objADORecordSet.Fields.Count - 1, larrayrowno - 1)
      
   DataBase_SQLToArray = vaTemporary
   
   Exit Function
   
ErrorHandler:
   Call Error_Handle(Err.Number & " - " & Err.Description, "DataBase_SQLToArray")
End Function

Database_SQLToArrayAppend

Public Function DataBase_SQLToArrayAppend( _
         ByVal vaOriginalArray As Variant, _
         ByVal objADORecordSet As ADODB.Recordset, _
Optional ByVal bIncludeFieldNames As Boolean = False) _
         As Variant

Dim lupperbound As Long
Dim larrayrowno As Long
Dim larraycolno As Long
Dim ifieldnumber As Integer

   On Error GoTo ErrorHandler
   
   If objADORecordSet.state <> ADODB.adStateOpen Or _
      objADORecordSet.EOF = True Then
      
      DataBase_SQLToArrayAppend = Empty
      Exit Function
   End If
   
   If Array_ContainsData(vaOriginalArray) = True Then
      lupperbound = UBound(vaOriginalArray, 2)
      larrayrowno = lupperbound + 1
      
      'add 100 blank rows to the original array
      ReDim Preserve vaOriginalArray(objADORecordSet.Fields.Count - 1, larrayrowno + 100)
   Else
      lupperbound = 0
      larrayrowno = 0
      
      ReDim vaOriginalArray(objADORecordSet.Fields.Count - 1, larrayrowno + 100)
   End If
   
      
   larraycolno = 0
   If bIncludeFieldNames = True Then
      For ifieldnumber = 1 To objADORecordSet.Fields.Count
         vaOriginalArray(larraycolno, larrayrowno) = CStr(objADORecordSet.Fields(ifieldnumber - 1).Name)
         
         larraycolno = larraycolno + 1
      Next ifieldnumber
      
      larrayrowno = larrayrowno + 1
   End If

   While Not objADORecordSet.EOF
      larraycolno = 0
      
      If larrayrowno > 0 And larrayrowno Mod 100 = 0 Then
         ReDim Preserve vaOriginalArray(objADORecordSet.Fields.Count - 1, lupperbound + larrayrowno + 100)
      End If
      
      For ifieldnumber = 1 To objADORecordSet.Fields.Count
       
         If IsNull(objADORecordSet.Fields(ifieldnumber - 1).Value) = False Then
            vaOriginalArray(larraycolno, larrayrowno) = Trim(CStr(objADORecordSet.Fields(ifieldnumber - 1).Value))
         End If
         
         larraycolno = larraycolno + 1
      Next ifieldnumber
      
      objADORecordSet.MoveNext
      larrayrowno = larrayrowno + 1
   Wend
   
   ReDim Preserve vaOriginalArray(objADORecordSet.Fields.Count - 1, larrayrowno - 1)

   DataBase_SQLToArrayAppend = vaOriginalArray
   
   Exit Function
   
ErrorHandler:
   Call Error_Handle(Err.Number & " - " & Err.Description, "DataBase_SQLToArrayAppend")
End Function

Database_TablesToListCombo

Public Sub Database_TablesToListCombo( _
         ByVal ctlBoxName As Control)

Dim ltotalrecords As Long
Dim lrownumber As Long

   On Error GoTo ErrorHandler

   Set gobjADORecordSet = gobjADOConnect.OpenSchema(adSchemaTables)

   ltotalrecords = gobjADORecordSet.RecordCount
   If (ltotalrecords > 0) Then
            
      If gobjADORecordSet.State = ADODB.adStateOpen Then
         
         For lrownumber = (ltotalrecords - gobjADORecordSet.RecordCount + 1) To ltotalrecords
         
            If gobjADORecordSet("TABLE_TYPE") = "TABLE" Then
            
               ctlBoxName.AddItem gobjADORecordSet("TABLE_NAME").Value
            
            End If
            
            gobjADORecordSet.MoveNext
         Next lrownumber
      End If
   End If
   
   Set gobjADORecordSet = Nothing

   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Database_TablesToListCombo", msMODULENAME, 1, _
        "")
End Sub

Message_DataSourceMergePromptUserToQuestion

Public Function Message_DataSourceMergePromptUserToQuestion() _
         As Boolean

Dim breturn As Boolean
Dim objreturn As VBA.VbMsgBoxResult

   If gbEND = True Then 
      Exit Function
   End If

   objreturn = MsgBox( _
               "This document has not yet been merged with its data source." & _
               vbCrLf & _
               vbCrLf & _
               "Would you like to merge the document now ?", _
               VBA.VbMsgBoxStyle.vbYesNo + VBA.VbMsgBoxStyle.vbQuestion, _
               gsFORM_TITLE)

   If objreturn = VBA.VbMsgBoxResult.vbYes Then breturn = True
   If objreturn = VBA.VbMsgBoxResult.vbNo Then breturn = False
   DataSourceMergePromptUserToQuestion = breturn
End Function

---

© 2026 Better Solutions Limited. All Rights Reserved. © 2026 Better Solutions Limited Top