VBA Snippets
Database_AddResults
Public Sub Database_AddResults(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 AnError
' 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
AnError:
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 AnError
dbADORecordset.MoveFirst
Database_ContainsData = True
Exit Function
AnError:
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 AnError
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
AnError:
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 AnError
Set vArrayName = Nothing
Database_ResultsToArrayMulti = False
ltotalrecords = gobjADORecordSet.RecordCount
If ltotalrecords > 0 Then
Database_ResultsToArrayMulti = True
If bIncludeFields = True Then ltotalrecords = ltotalrecords + 1
If iNoOfColumns = -1 Then ReDim vArrayName(gobjADORecordSet.Fields.Count, ltotalrecords)
If iNoOfColumns > 0 Then ReDim vArrayName(iNoOfColumns - 1, ltotalrecords - 1)
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) = ""
If iPopulateCol > 0 Then vArrayName(iPopulateCol, lrownumber) = ""
Else
If iPopulateCol = -1 Then _
vArrayName(ifieldnumber, lrownumber) = _
CStr(gobjADORecordSet.Fields(ifieldnumber).Value)
If iPopulateCol > 0 Then _
vArrayName(iPopulateCol, lrownumber) = _
CStr(gobjADORecordSet.Fields(ifieldnumber).Value)
End If
End If
Next ifieldnumber
gobjADORecordSet.MoveNext
Next lrownumber
End If
End If
Set gobjADORecordSet = Nothing
If gbDEBUG = False Then Exit Function
AnError:
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(sArrayName As String, _
vArrayName As Variant, _
Optional bIncludeField As Boolean = False)
Dim ltotalrecords As Long
Dim lrownumber As Long
Dim lrecordcounter As Long
Dim ifieldnumber As Integer
On Error GoTo AnError
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
AnError:
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(ctlBoxName As Control)
Dim lrownumber As Long
Dim ifieldnumber As Integer
On Error GoTo AnError
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
AnError:
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 AnError
If gbDEBUG = False Then Exit Sub
AnError:
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 AnError
If gbDEBUG = False Then Exit Sub
AnError:
Call Error_Handle("Database_ResultsToTextFile", msMODULENAME, 1, _
"")
End Sub
Database_SQLParameterDeclare
Declares a parameter for calling a database stored procedure.Public Sub Database_SQLParameterDeclare(iType As Integer, _
iDirection As Integer, _
Optional iSize As Integer = 0, _
Optional sValue As Variant = "??", _
Optional sParameterName As String = "ParamName")
On Error GoTo AnError
Set gobjADOParameter = New ADODB.Parameter
If sValue <> "??" Then _
Set gobjADOParameter = gobjADOCommand.CreateParameter(sParameterName, _
iType, iDirection, iSize, sValue)
If sValue = "??" Then _
Set gobjADOParameter = gobjADOCommand.CreateParameter(sParameterName, _
iType, iDirection, iSize)
gobjADOCommand.Parameters.Append dbADOParameter
Set gobjADOParameter = Nothing
If gbDEBUG = False Then Exit Sub
AnError:
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(sProcFuncName As String, _
Optional bReturnValue As Boolean = False, _
Optional bRowReturning As Boolean = False, _
Optional iReturnType As Integer, _
Optional iReturnSize As Integer, _
Optional sVar1Value As Variant = "", _
Optional iVar1Type As Integer = 1, _
Optional sVar2Value As Variant = "", _
Optional iVar2Type As Integer = 1, _
Optional sVar3Value As Variant = "", _
Optional iVar3Type As Integer = 1, _
Optional sVar4Value As Variant = "", _
Optional iVar4Type As Integer = 1, _
Optional sVar5Value As Variant = "", _
Optional iVar5Type As Integer = 1, _
Optional sVar6Value As Variant = "", _
Optional iVar6Type As Integer = 1) As Variant
On Error GoTo AnError
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)
If sVar1Value <> "" Then _
Call DataBase_SQLParameterDeclare(iVar1Type, adParamInput, sVar1Value, 10)
If sVar2Value <> "" Then _
Call DataBase_SQLParameterDeclare(iVar2Type, adParamInput, sVar2Value, 10)
If sVar3Value <> "" Then _
Call DataBase_SQLParameterDeclare(iVar3Type, adParamInput, sVar3Value, 10)
If sVar4Value <> "" Then _
Call DataBase_SQLParameterDeclare(iVar4Type, adParamInput, sVar4Value, 10)
If sVar5Value <> "" Then _
Call DataBase_SQLParameterDeclare(iVar5Type, adParamInput, sVar5Value, 10)
If sVar6Value <> "" Then _
Call DataBase_SQLParameterDeclare(iVar6Type, adParamInput, sVar6Value, 10)
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")
Set dbADOCommand = Nothing
If gbDEBUG = False Then Exit Function
AnError:
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(sProcFuncName As String, _
Optional bReturnValue As Boolean = False, _
Optional bRowReturning As Boolean = False, _
Optional iReturnType As Integer, _
Optional 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
AnError:
Call Error_Handle("Database_SQLProcFuncDeclare", msMODULENAME, 1,
Err.Number & " " & Err.Description)
End Sub
Database_SQLProcFuncExecute
Public Sub Database_SQLProcFuncExecute(Optional bReturnValue As Boolean = False, _
Optional sOutParameter1 As String = "", _
Optional vReturnValue1 As Variant, _
Optional sOutParameter2 As String = "", _
Optional vReturnValue2 As Variant, _
Optional sOutParameter3 As String = "", _
Optional vReturnValue3 As Variant)
On Error GoTo AnError
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
If Len(sOutParameter2) > 0 Then
If Not IsNull(gobjADOCommand(sOutParameter2).Value) Then _
vReturnValue2 = gobjADOCommand(sOutParameter2).Value
End If
If Len(sOutParameter3) > 0 Then
If Not IsNull(gobjADOCommand(sOutParameter3).Value) Then _
vReturnValue3 = gobjADOCommand(sOutParameter3).Value
End If
End If
Set gobjADOCommand = Nothing
If gbDEBUG = False Then Exit Sub
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
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 bReturnRecordSet As Boolean = False, _
Optional bReturnValue As Boolean = False) As Variant
On Error GoTo AnError
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
If gbDEBUG = False Then Exit Function
AnError:
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 AnError
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
AnError:
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 AnError
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
AnError:
Call Error_Handle(Err.Number & " - " & Err.Description, "DataBase_SQLToArrayAppend")
End Function
Database_TablesToListCombo
Public Sub Database_TablesToListCombo(ctlBoxName As Control)
Dim ltotalrecords As Long
Dim lrownumber As Long
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
AnError:
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
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
© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top