VB_CLS_ACCESS

'Imports Microsoft.Office.Interop

Public Class Access

    'Private oAccess As Microsoft.Office.Interop.Access.Application
    'Public BD As Microsoft.Office.Interop.Access.Dao.Database

    Private oAccess As Object
    Public BD As Object


    Public Sub New(StrRutaBD As String, StrBD As String, Optional esVisible As Boolean = True)

        _sRutaBD = StrRutaBD : _sBD = StrBD
        _bVisible = esVisible

        'oAccess = New Microsoft.Office.Interop.Access.Application
        oAccess = CreateObject("Access.Application")


        'If StrRutaBD <> "" Then
        '    oAccess.OpenCurrentDatabase(sRutaBD & sBD, False)
        'End If

        'Run the macro.
        'oAccess.Run("ImportTxtFile")

        'Quit Access without saving the database.

        '  oAccess.CurrentDb.Close()
        ' oAccess = Nothing

    End Sub


#Region "PROPIEDADES"

    Private _sError As String
    Public Property sError() As String
        Get
            Return _sError
        End Get
        Set(ByVal value As String)
            _sError = value
        End Set
    End Property

    Private _bVisible As Boolean
    Public Property bVisible() As Boolean
        Get
            Return _bVisible
        End Get
        Set(ByVal value As Boolean)
            _bVisible = value
        End Set
    End Property

    Private _sRutaBD As String
    Public Property sRutaBD() As String
        Get
            Return _sRutaBD
        End Get
        Set(ByVal value As String)
            _sRutaBD = value
        End Set
    End Property

    Private _sBD As String
    Public Property sBD() As String
        Get
            Return _sBD
        End Get
        Set(ByVal value As String)
            _sBD = value
        End Set
    End Property

    Private _Sql As String
    Public Property Sql() As String
        Get
            Return _Sql
        End Get
        Set(ByVal value As String)
            _Sql = value
        End Set
    End Property

    Private _Macro As String
    Public Property Macro() As String
        Get
            Return _Macro
        End Get
        Set(ByVal value As String)
            _Macro = value
        End Set
    End Property

#End Region


#Region "MÉTODOS PÚBLICOS"


    Public Sub Abrir()
        oAccess.OpenCurrentDatabase(_sRutaBD & _sBD, False, "Jorge")
        BD = oAccess.CurrentDb
        oAccess.Application.Visible = _bVisible
        oAccess.DoCmd.Minimize()
    End Sub

    Public Sub Cerrar()
        BD.Close() : BD = Nothing
        ''oAccess.Application.Quit()
        'oAccess = Nothing

        oAccess.CloseCurrentDatabase()
        oAccess.Application.Quit()

    End Sub

    Public Sub Matar()
        oAccess.Application.Quit()
    End Sub

    'Public Sub CompactaBD(RutaBD As String, NomBD As String)
    'Public Sub CompactaBD()

    '    'oAccess.CompactRepair(sRutaBD & "aaa.mbd", sRutaBD & sBD)

    '    Dim jro As JRO.JetEngine

    '    jro = New JRO.JetEngine()

    '    jro.CompactDatabase("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sRutaBD & sBD, _
    '    "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sRutaBD & "aaa.mdb;Jet OLEDB:Engine Type=5")

    'End Sub

    Public Sub EjecutaSQL()
        On Error GoTo Trata_Error

        oAccess.DoCmd.RunSQL(_Sql)

        Exit Sub
Trata_Error:
        _sError = "oAccess.EjecutaSQL : " & Err.Description
    End Sub

    Public Sub EjecutaMacro()
        On Error GoTo Trata_Error

        oAccess.DoCmd.RunMacro(_Macro)

        Exit Sub
Trata_Error:
        _sError = "oAccess.EjecutaMacro : " & Err.Description
    End Sub


    Public Sub ModificaVista(Vista As String, sQuery As String)

        'Between Date()-1 And Date()
        'Between(#7/15/2013# And #7/16/2013#)

        'sQuery = Replace(sQuery, "Between Date()-1 And Date()", "Between #7/15/2013# And #7/16/2013#")

        BD.QueryDefs(Vista).SQL = sQuery

    End Sub

    Public Function DameMaxFecha(StrTabla As String, StrCampo As String) As String

        On Error GoTo TrataError

        'Dim StrRes As String, Rs As Dao.Recordset
        Dim StrRes As String, Rs As Object

        _Sql = "SELECT MAX(" & StrCampo & ") FROM " & StrTabla

        Rs = oAccess.CurrentDb.OpenRecordset(_Sql)

        If IsDBNull(Rs(0)) Then StrRes = "" Else StrRes = CStr(Rs(0).Value)

        DameMaxFecha = StrRes

        Rs.Close() : Rs = Nothing

        Exit Function
TrataError:
        DameMaxFecha = "DameMaxFecha() : " & Err.Description
    End Function

    ''' <summary>
    ''' Exportación de Access a Txt/csv Mediante DoCmd.TransferText
    ''' </summary>
    ''' <param name="sVista">Vista de Origen y Especificación Access de Exportación</param>
    ''' <param name="RutaFic"></param>
    ''' <param name="Tipo">Txt / csv</param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Function ExportaTxt(sVista As String, RutaFic As String, Optional Tipo As String = "txt") As String

        ExportaTxt = ""
        On Error GoTo TrataError

        ' .TransferText(TransferType (1-Import;2-Export), SpecificationName, TableName, FileName, HasFieldNames, HTMLTableName, CodePage)
        oAccess.DoCmd.TransferText(2, sVista, sVista, RutaFic, True)

        Exit Function
TrataError:
        ExportaTxt = "ERROR : Access.ExportaTxt " & Err.Description
    End Function

    Public Sub CamposTabla(sTabla As String)

        'Dim oTabla As Dao.TableDef, oCampo As Dao.Field
        Dim oTabla As Object, oCampo As Object

        oTabla = oAccess.CurrentDb.TableDefs(sTabla)

        Debug.Print("TABLA : " & sTabla)

        For i = 0 To oTabla.Fields.Count - 1
            oCampo = oTabla.Fields(i)
            Debug.Print(oCampo.Name & " : " & TipoCampo(oCampo))
        Next

        'For i = 0 To oAccess.CurrentDb.TableDefs.Count - 1
        '    Debug.Print("TABLA : " & oAccess.CurrentDb.TableDefs(i).Name)
        '    For x = 0 To oAccess.CurrentDb.TableDefs(i).Fields.Count - 1
        '        Debug.Print(oAccess.CurrentDb.TableDefs(i).Fields(x).Name & " : " & TipoCampo(oAccess.CurrentDb.TableDefs(i).Fields(x)))
        '        'For z = 0 To oAccess.CurrentDb.TableDefs(i).Fields(x).Properties.Count - 1
        '        '    Debug.Print(oAccess.CurrentDb.TableDefs(i).Fields(x).Properties(z).Name) '& " : " & oAccess.CurrentDb.TableDefs(i).Fields(x).Properties(z).value)
        '        'Next
        '    Next
        '    Debug.Print("***********************************")
        'Next

    End Sub

    'Private Function TipoCampo(Campo As Dao.Field) As String
    Private Function TipoCampo(Campo As Object) As String

        Dim StrTipo As String

        Select Case CLng(Campo.Type)
            Case 1 : StrTipo = "Yes/No"
            Case 2 : StrTipo = "Byte"
            Case 3 : StrTipo = "Integer"
            Case 4 : StrTipo = "AutoNumber"
                'If (Campo.Attributes And dbAutoIncrField) = 0& Then
                '    StrTipo = "Long Integer"
                'Else
                '    StrTipo = "AutoNumber"
                'End If
            Case 5 : StrTipo = "Currency"         '
            Case 6 : StrTipo = "Single"
            Case 7 : StrTipo = "Double"
            Case 8 : StrTipo = "Date/Time"
            Case 9 : StrTipo = "Binary"
            Case 10 : StrTipo = "Text"
                'If (Campo.Attributes And dbFixedField) = 0& Then
                '    StrTipo = "Text"
                'Else
                '    StrTipo = "Text (fixed width)"        '(no interface)
                'End If
            Case 11 : StrTipo = "OLE Object"
            Case 12 : StrTipo = "Memo"
                'If (Campo.Attributes And dbHyperlinkField) = 0& Then
                '    StrTipo = "Memo"
                'Else
                '    StrTipo = "Hyperlink"
                'End If
            Case 15 : StrTipo = "GUID"                 '15

                'Attached tables only: cannot create these in JET.
            Case 16 : StrTipo = "Big Integer"
            Case 17 : StrTipo = "VarBinary"
            Case 18 : StrTipo = "Char"
            Case 19 : StrTipo = "Numeric"
            Case 20 : StrTipo = "Decimal"
            Case 21 : StrTipo = "Float"
            Case 22 : StrTipo = "Time"
            Case 23 : StrTipo = "Time Stamp"

                'Constants for complex types don't work prior to Access 2007 and later.
            Case 101& : StrTipo = "Attachment"
            Case 102& : StrTipo = "Complex Byte"
            Case 103& : StrTipo = "Complex Integer"
            Case 104& : StrTipo = "Complex Long"
            Case 105& : StrTipo = "Complex Single"
            Case 106& : StrTipo = "Complex Double"
            Case 107& : StrTipo = "Complex GUID"
            Case 108& : StrTipo = "Complex Decimal"
            Case 109& : StrTipo = "Complex Text"
            Case Else : StrTipo = "Desconocido"
        End Select

        TipoCampo = StrTipo

    End Function

#End Region

End Class




#Region "REFERENCIA"


'http://msdn.microsoft.com/es-es/library/office/dn142571%28v=office.15%29.aspx

'************* DoCmd.TransferText
'http://msdn.microsoft.com/es-es/library/office/ff835958%28v=office.15%29.aspx

'************* DoCmd.TransferSpreadsheet
'http://msdn.microsoft.com/es-es/library/office/ff844793%28v=office.15%29.aspx


#End Region

#Region "CÓDIGO FUENTE"

'Private Sub PropiedadesBD()

'For Each prpLoop In BD.Properties
'    With prpLoop
'        Debug.Print(" " & .Name)
'        Debug.Print(" Type: " & .Type)
'        Try
'            Debug.Print(" Value: " & .Value)
'        Catch ex As Exception
'            Debug.Print(" Value: ERROR")
'        End Try

'        Debug.Print(" Inherited: " & .Inherited)
'        Debug.Print("***************************************************************")
'    End With
'Next prpLoop

'End Sub


'Function TableInfo(strTableName As String)
'    On Error GoTo TableInfoErr
'    ' Purpose:   Display the field names, types, sizes and descriptions for a table.
'    ' Argument:  Name of a table in the current database.
'    Dim db As DAO.Database
'    Dim tdf As DAO.TableDef
'    Dim fld As DAO.Field

'    db = CurrentDb()
'    tdf = db.TableDefs(strTableName)
'    Debug.Print("FIELD NAME", "FIELD TYPE", "SIZE", "DESCRIPTION")
'    Debug.Print("==========", "==========", "====", "===========")

'    For Each fld In tdf.Fields
'      Debug.Print fld.Name,
'      Debug.Print FieldTypeName(fld),
'      Debug.Print fld.Size,
'      Debug.Print GetDescrip(fld)
'    Next
'    Debug.Print("==========", "==========", "====", "===========")

'TableInfoExit:
'    db = Nothing
'    Exit Function

'TableInfoErr:
'    Select Case Err
'        Case 3265&  'Table name invalid
'            MsgBox(strTableName & " table doesn't exist")
'        Case Else
'      Debug.Print "TableInfo() Error " & Err & ": " & Error
'    End Select
'    Resume TableInfoExit
'End Function


'Function GetDescrip(obj As Object) As String
'    On Error Resume Next
'    GetDescrip = obj.Properties("Description")
'End Function


'Function FieldTypeName(fld As DAO.Field) As String
'    'Purpose: Converts the numeric results of DAO Field.Type to text.
'    Dim strReturn As String    'Name to return

'    Select Case CLng(fld.Type) 'fld.Type is Integer, but constants are Long.
'        Case dbBoolean : strReturn = "Yes/No"            ' 1
'        Case dbByte : strReturn = "Byte"                 ' 2
'        Case dbInteger : strReturn = "Integer"           ' 3
'        Case dbLong                                     ' 4
'            If (fld.Attributes And dbAutoIncrField) = 0& Then
'                strReturn = "Long Integer"
'            Else
'                strReturn = "AutoNumber"
'            End If
'        Case dbCurrency : strReturn = "Currency"         ' 5
'        Case dbSingle : strReturn = "Single"             ' 6
'        Case dbDouble : strReturn = "Double"             ' 7
'        Case dbDate : strReturn = "Date/Time"            ' 8
'        Case dbBinary : strReturn = "Binary"             ' 9 (no interface)
'        Case dbText                                     '10
'            If (fld.Attributes And dbFixedField) = 0& Then
'                strReturn = "Text"
'            Else
'                strReturn = "Text (fixed width)"        '(no interface)
'            End If
'        Case dbLongBinary : strReturn = "OLE Object"     '11
'        Case dbMemo                                     '12
'            If (fld.Attributes And dbHyperlinkField) = 0& Then
'                strReturn = "Memo"
'            Else
'                strReturn = "Hyperlink"
'            End If
'        Case dbGUID : strReturn = "GUID"                 '15

'            'Attached tables only: cannot create these in JET.
'        Case dbBigInt : strReturn = "Big Integer"        '16
'        Case dbVarBinary : strReturn = "VarBinary"       '17
'        Case dbChar : strReturn = "Char"                 '18
'        Case dbNumeric : strReturn = "Numeric"           '19
'        Case dbDecimal : strReturn = "Decimal"           '20
'        Case dbFloat : strReturn = "Float"               '21
'        Case dbTime : strReturn = "Time"                 '22
'        Case dbTimeStamp : strReturn = "Time Stamp"      '23

'            'Constants for complex types don't work prior to Access 2007 and later.
'        Case 101& : strReturn = "Attachment"         'dbAttachment
'        Case 102& : strReturn = "Complex Byte"       'dbComplexByte
'        Case 103& : strReturn = "Complex Integer"    'dbComplexInteger
'        Case 104& : strReturn = "Complex Long"       'dbComplexLong
'        Case 105& : strReturn = "Complex Single"     'dbComplexSingle
'        Case 106& : strReturn = "Complex Double"     'dbComplexDouble
'        Case 107& : strReturn = "Complex GUID"       'dbComplexGUID
'        Case 108& : strReturn = "Complex Decimal"    'dbComplexDecimal
'        Case 109& : strReturn = "Complex Text"       'dbComplexText
'        Case Else : strReturn = "Field type " & fld.Type & " unknown"
'    End Select

'    FieldTypeName = strReturn
'End Function

#End Region