'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
Comments