Attribute VB_Name = "lib_adodb_for_xls"
'-------------------------------------------------------------------------------
'File         : lib_adodb_for_xls.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://http://wiki.yaslaw.info/dokuwiki/doku.php/vba/excel/adodbsql
'Environment  : VBA 2010 +
'Version      : 1.4.0
'Name         : lib_adodb_for_xls
'Author       : Stefan Erb (ERS)
'History      : 27.01.2016 - ERS - Creation
'             : 20.06.2016 - ERS - Vollständig auf LateBinding umgestellt
'             : 27.10.2016 - ERS - Connectionparamters axConnParams hinzugefügt
'               02.11.2016 - ERS - Korrektur: Wenn die axConnParams verändert daherkommen, wird die Connection neu aufgebaut
'               07.08.2017 - ERS - Bei der Connection den optionalen Parameter filePath hinzugefügt. Header Konvertierung hinzugefügt, ZielRange kann jetzt auch ein Worksheet oder eine Adresse sein
'-------------------------------------------------------------------------------
Option Explicit

'-------------------------------------------------------------------------------
' -- Settings
'-------------------------------------------------------------------------------
'https://www.connectionstrings.com/ace-oledb-12-0/
Const C_CONN_STR = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='{#FILEPATH}'; Extended Properties='Excel 12.0;HDR={#HDR};IMEX=1'"

'-------------------------------------------------------------------------------
' -- Public Members
'-------------------------------------------------------------------------------

'/**
' * Paramters zur Connection
' */
Public Enum axConnParams
    axcNone = 0
    axcReconnect = 2 ^ 0    'Ein Reconnect wird erzwungen
    axcNoHeader = 2 ^ 1     'Die erste Zeile ist keine Kopfzeile. Die Felder werden mit f1, f2...fx angesprochen
End Enum

'/**
' * Paramters zum Schreiben der Daten
' */
Public Enum axWriteParams
    axwNone = 2 ^ 0             'Keine umwandlung
    axwHeaderRedable = 2 ^ 1    'Titel mit Unterlinien werden aufgetrennt "HAUS_NUMMER" -> "Haus Nummer"
End Enum


'-------------------------------------------------------------------------------
' -- Private Members
'-------------------------------------------------------------------------------

'/**
' * Die Parameter für das ADODB Objekt
' * https://docs.microsoft.com/en-us/sql/ado/reference/ado-api/open-method-ado-recordset
' */
Private Enum lateBindingAdodbParameters
    adDate = 7
    adDouble = 5
    adStateOpen = 1
    adCmdText = 1
    adUseClient = 3
    adOpenDynamic = 2
    adOpenStatic = 3
    adLockOptimistic = 3
    adLockReadOnly = 1
End Enum

'-------------------------------------------------------------------------------
' -- Public Methodes
'-------------------------------------------------------------------------------

'/**
' * Open a adodb recordset from the current workbook
' * @param  String          SQL-String
' * @param  axConnParams    Paramters für die Connection
' * @return ADODB.Recordset
' */
Public Function openRs(ByVal iSql As String, Optional ByVal iConnParams As axConnParams = axcNone) As Object
    Dim rst As Object: Set rst = CreateObject("ADODB.Recordset")
    Dim cmd As Object: Set cmd = CreateObject("ADODB.Command")

    Set cmd.ActiveConnection = connection(Abs(iConnParams)) 'Der abs() ist false jemand von Früher false übergibt.
    cmd.CommandType = adCmdText
    cmd.CommandText = iSql

    rst.CursorLocation = adUseClient
    rst.CursorType = adOpenStatic
    rst.LockType = adLockReadOnly

    'open the recordset
    rst.Open cmd

    'disconnect the recordset
    Set rst.ActiveConnection = Nothing

    'cleanup
    If cmd.State = adStateOpen Then
        Set cmd = Nothing
    End If
    Set openRs = rst
End Function

'/**
' * Schreibt ins Excel inkl Header
' * @param  Range   First cell
' * @param  Recordset
' */
Public Sub writeFullData(ByRef iRange As Variant, ByRef ioRs As Object, Optional ByVal iWriteParams As axWriteParams = axwNone)
    Dim trg As range:   Set trg = castRange(iRange)
    writeHeader trg, ioRs, iWriteParams
    writeData trg.offset(1), ioRs
End Sub

'/**
' * Write the Header of a adodb.recordset
' * @param  Range   First cell
' * @param  Recordset
' */
Public Sub writeHeader(ByRef iRange As Variant, ByRef ioRs As Object, Optional ByVal iWriteParams As axWriteParams = axwNone)
    Dim trg As range:   Set trg = castRange(iRange)
    Dim colNr As Long
    Dim delta As Long:  delta = trg.Column
    trg.ClearContents
    For colNr = 0 To ioRs.fields.count - 1
        Dim txt As String: txt = ioRs.fields(colNr).name
        If Not andB(iWriteParams, axwNone) Then txt = strConv(Join(Split(txt, "_"), " "), vbProperCase)
        trg.Worksheet.Cells(iRange.row, colNr + delta).value = txt
    Next
End Sub

'/**
' * Schreibt die Daten
' * @param  Range
' * @param  Recordset
' */
Public Sub writeData(ByRef iRange As Variant, ByRef iRs As Object)
    Dim trg As range:   Set trg = castRange(iRange)
    trg.ClearContents
    trg.CopyFromRecordset iRs
End Sub

'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------

'/**
' * Parst Sheet und String in ein Range
' * @param  Worksheet/Range/Address
' * @return Range
' */
Private Function castRange(ByRef iVar As Variant) As range
    Select Case TypeName(iVar)
        Case "Worksheet":       Set castRange = iVar.UsedRange
        Case "Range":           Set castRange = iVar
        Case "String":          Set castRange = ActiveSheet.range(iVar)
    End Select
End Function

'-------------------------------------------------------------------------------
' -- Private Properties
'-------------------------------------------------------------------------------

'/**
' * Handle dhe adodb-connection to the current workbook
' * @param  axConnParams    Paramters für die Connection
' * @param  String          Pfad zur QuellDatei. Standard ist der Pfad des ausführenden Workbooks
' * @return ADODB.Conection
' */
Private Property Get connection(Optional ByVal iConnParams As axConnParams = axcNone, Optional ByVal iFilePath As String = Empty) As Object
    Static pConn As Object
    Static pParams As axConnParams
    If pConn Is Nothing Or andB(iConnParams, axcReconnect) Or pParams <> iConnParams Then
        pParams = iConnParams
        Dim filePath As String: filePath = IIf(iFilePath = Empty, ThisWorkbook.FullName, iFilePath)
        Dim connString As String: connString = Replace(Replace(C_CONN_STR, "{#FILEPATH}", filePath), "{#HDR}", IIf(andB(iConnParams, axcNoHeader), "No", "Yes"))
        Set pConn = CreateObject("ADODB.Connection")
        pConn.ConnectionString = connString
    End If
    If Not (pConn.State And adStateOpen) = adStateOpen Then
         pConn.Open
    End If
    Set connection = pConn
End Property

'-------------------------------------------------------------------------------
' -- Libraries
'-------------------------------------------------------------------------------

'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb
' * Macht einen Bit-Vergleich
' * @param  Long
' * @param  Long
' * @return Boolean
' */
Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
    andB = ((iHaystack And iNeedle) = iNeedle)
End Function