vbscript ADO RecordSet类

Posted 2021-05-21

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsADORecordSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'@Folder("HRDatabase.Database Management")

Const sModule                          As String = "clsADORecordSet"

'==================================================================================================================================================
'   MEMBER CONSTANTS
'==================================================================================================================================================


'==================================================================================================================================================
'   MEMBER VARIABLES
'==================================================================================================================================================

Private oRs                            As ADODB.Recordset
Private oConn                          As ADODB.Connection
Private oLastError                     As String
Private oError                         As Boolean

'==================================================================================================================================================
'   PROPERTIES
'==================================================================================================================================================

Public Property Get rs() As ADODB.Recordset
    Set rs = oRs
End Property

Public Property Set rs(ByVal ObjRs As ADODB.Recordset)
    Set oRs = ObjRs
End Property

Public Property Get LastError() As String
    LastError = oLastError
End Property
Public Property Get Error() As Boolean
    Error = oError
End Property

'==================================================================================================================================================
'   CLASS EVENTS
'==================================================================================================================================================

Private Sub Class_Initialize()
End Sub

Private Sub Class_Terminate()
    'close recordset
    CloseADORecordset
End Sub

Public Function Init() As clsADORecordSet
    Set oRs = New ADODB.Recordset
    Set Init = Me
End Function
Public Function InitConn(ByVal objConn As ADODB.Connection) As clsADORecordSet
    Set oConn = objConn
    Set oRs = New ADODB.Recordset
    Set InitConn = Me
End Function
Public Function InitSQLtoRecordset(ByVal objConn As ADODB.Connection, ByVal SQL_String As String) As clsADORecordSet
    Set oConn = objConn
    Set oRs = New ADODB.Recordset
    SQLtoRecordset (SQL_String)
    Set InitSQLtoRecordset = Me
End Function
Public Function InitOpenTableAsRecordSet(ByVal objConn As ADODB.Connection, ByVal strTable As String) As clsADORecordSet
    Set oConn = objConn
    Set oRs = New ADODB.Recordset
    OpenTableAsRecordSet (strTable)
    Set InitOpenTableAsRecordSet = Me
End Function

'==================================================================================================================================================
'   METHODS
'==================================================================================================================================================
Private Sub CloseADORecordset()
    On Error Resume Next
    If Not oRs Is Nothing Then
        If oRs.State = adStateOpen Then oRs.Close
    End If
    Set oRs = Nothing
    Set oConn = Nothing
    On Error GoTo 0
End Sub

'==================================================================================================================================================
'   FUNCTIONS
'==================================================================================================================================================

Public Function SQLtoRecordset(ByVal SQL_String As String) As Boolean
    'Description:   Executes a select query SQL
    'Input:         SQL command (string)
    'Output:        Recordset object
    
    'default value
    SQLtoRecordset = False
    oError = False
    
    'error handling
    On Error GoTo ADOError
    
    'check
    If oConn Is Nothing Then oError = True: oLastError = "No Connection": Exit Function
    If SQL_String = vbNullString Then oError = True: oLastError = "No SQL string": Exit Function
    
    With Me.rs
        .Source = SQL_String
        .ActiveConnection = oConn
        .CursorLocation = adUseClient 'to be compatible with read-only databases
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
        .Open
    End With
    
    SQLtoRecordset = True

ExitHere:
    Exit Function
ADOError:
    oError = True
    Dim Errs As ADODB.Errors
    Dim errLoop As ADODB.Error
    Dim strErr As String
    Dim i As Long
    i = 1
    ' Process
     strErr = strErr & vbCrLf & "VB Error # " & str(Err.Number)
     strErr = strErr & vbCrLf & "   Generated by " & Err.Source
     strErr = strErr & vbCrLf & "   Description  " & Err.Description
    
    ' Enumerate Errors collection and display properties of each Error object.
     Set Errs = oConn.Errors
     For Each errLoop In Errs
          With errLoop
            strErr = strErr & vbCrLf & "Error #" & i & ":"
            strErr = strErr & vbCrLf & "   ADO Error   #" & .Number
            strErr = strErr & vbCrLf & "   Description  " & .Description
            strErr = strErr & vbCrLf & "   Source       " & .Source
            i = i + 1
        End With
    Next errLoop
    oLastError = strErr
    Err.Clear
    Err.Clear: Resume ExitHere
    
End Function

Public Function OpenTableAsRecordSet(ByVal strTable As String) As Boolean
    'Description:   Megnyit egy Recordset-et
    'Input:         Tábla neve (String)
    'Output:        Recordset
    
    'default value
    OpenTableAsRecordSet = False
    oError = False
    
    'error handling
    On Error GoTo ADOError
    
    'check
    If oConn Is Nothing Then oError = True: oLastError = "No Connection": Exit Function
    If strTable = vbNullString Then oError = True: oLastError = "No Tabla string": Exit Function
    
    With Me.rs
        .ActiveConnection = oConn
        .Source = strTable
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic                         'adLockOptimistic // adLockReadOnly
        .Open Options:=adCmdTable                          'adCmdTable // adCmdTableDirect
    End With
    
    OpenTableAsRecordSet = True

ExitHere:
    Exit Function
ADOError:
    oError = True
    Dim Errs As Errors
    Dim errLoop As Error
    Dim strErr As String
    Dim i As Long
    i = 1
    ' Process
     strErr = strErr & vbCrLf & "VB Error # " & str(Err.Number)
     strErr = strErr & vbCrLf & "   Generated by " & Err.Source
     strErr = strErr & vbCrLf & "   Description  " & Err.Description
    
    ' Enumerate Errors collection and display properties of each Error object.
     Set Errs = oConn.Errors
     For Each errLoop In Errs
          With errLoop
            strErr = strErr & vbCrLf & "Error #" & i & ":"
            strErr = strErr & vbCrLf & "   ADO Error   #" & .Number
            strErr = strErr & vbCrLf & "   Description  " & .Description
            strErr = strErr & vbCrLf & "   Source       " & .Source
            i = i + 1
        End With
    Next errLoop
    oLastError = strErr
    Err.Clear
    Err.Clear: Resume ExitHere
    
End Function

Public Function CopyADORecordsetToArray(ByRef outputArr As Variant) As Boolean
'Description:   Recordset-et 2D tömbbe menti
'Input:         Recordset
'Output:        2D array
'Dependency:    modArraySupport

    'Default value
    CopyADORecordsetToArray = False
    
    If Me.rs.RecordCount < 1 Then Exit Function
    
    With Me.rs
        .MoveFirst
        Dim tempArr() As Variant
        tempArr = .GetRows
        HandleNulls tempArr
        Dim transposedArr() As Variant
        If TransposeArray(tempArr, transposedArr) = False Then Exit Function 'tempArr = Application.WorksheetFunction.Transpose(tempArr) '--> converts date to string!!!
        If ConvertToOneBasedArray(transposedArr) = False Then Exit Function
        outputArr = transposedArr
    End With

    CopyADORecordsetToArray = True
    
End Function

Function GetADORecordsetHeader(outputArr As Variant) As Boolean
'Description:   Recordset fejlécet egy 2D tömbbe menti
'Input:         Recordset
'Output:        2D array

'******   DEKLARÁCIÓK   ********************
Dim tempArr()   As Variant
Dim i           As Long
'*******************************************

    'Default value
    GetADORecordsetHeader = False

    With Me.rs
        ReDim tempArr(1 To 1, 1 To .Fields.Count)
    
        For i = 1 To .Fields.Count
            'Mező/oszlop név:
            tempArr(1, i) = .Fields(i - 1).Name
        Next i
    End With
    outputArr = tempArr

    GetADORecordsetHeader = True

End Function

Public Function GetRecord(ByRef outputVal As Variant, ByVal outputColumnName As String, ByVal filterColumnName As String, ByVal filterValue As Variant) As Boolean
'Description:   Recordset-ből egy rekordot kiválaszt
'Input:         Recordset; Output mező neve; szűrőmező neve (ID); szűrő értéke
'Output:        1 db érték

'******   DEKLARÁCIÓK   ********************
Dim filterString As String
'*******************************************

    'Default value
    GetRecord = False

    With Me.rs
    '   Mező típusa alapján különböző FilterString
        Select Case .Fields(filterColumnName).Type
            Case adVarNumeric, adInteger, adTinyInt, adSmallInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt, adDecimal, adSingle, adDouble, adBigInt, adDate, adFileTime, adNumeric
                filterString = CStr(filterColumnName & "=" & filterValue)
            Case adVarChar, adChar, adLongVarChar, adLongVarWChar, adVarWChar, adWChar
                filterString = CStr(filterColumnName & "='" & filterValue & "'")
            Case adDBDate, adDBTimeStamp
                filterString = CStr(filterColumnName & "=#" & filterValue & "#")
                'filterString = CStr(FilterColumnName & "= #" & year(datevalue(FilterValue)) & "-" &  right("00" & month(datevalue(FilterValue)),2) & "-" &  right("00" & day(datevalue(FilterValue)),2) & "#"
                'filterString = CStr(FilterColumnName & "= #" & year(datevalue(FilterValue)) & "-" & right("00" & month(datevalue(FilterValue)),2) & "-" & right("00" & day(datevalue(FilterValue)),2) & " " & Right("00" & Hour(datevalue(FilterValue)),2) & ":" & Right("00" & Minute(datevalue(FilterValue)),2) & ":" & Right("00" & Second(datevalue(FilterValue)),2) & "#"
        End Select
        filterString = CStr(filterColumnName & "='" & filterValue & "'")
        .Filter = filterString
        
        Select Case .RecordCount
            Case 0
                'nincs találat
                MsgBox "HIBA: Nincs találat az alábbi kondícióra" & vbNewLine & "WHERE " & filterString, vbCritical, "HIBA"
                Exit Function
            Case 1
                'egy találat -> sikeres szűrés
                outputVal = .Fields(outputColumnName).Value
            Case Else
                'több találat, nem egyedi értékre szűrtünk
                MsgBox "HIBA: Több mint egy találat az alábbi kondícióra" & vbNewLine & "WHERE " & filterString, vbCritical, "HIBA"
                Exit Function
        End Select
    End With
        
    GetRecord = True
    
End Function