Reinstalando todo...
Application.SetOption "Key Assignment Macro", "Autokeys"
Like "[*]*"
Dim rst As DAO.Recordset
Dim rstFiltrado As DAO.Recordset
Set rst = CurrentDb.OpenRecordset("SELECT * FROM unaTabla WHERE UnCampo = '" & unValor & "'")
rst.Filter = "OtroCampo = 'otroValor'"
Set rstFiltrado = rst.OpenRecordset
' Acciones
rstFiltrado.Close
Set rstFiltrado = Nothing
Function CompactarOtraBDD(strFullPath As String)
On Error GoTo ErrorHandler
Dim strNewNombre As String
Dim strBackend As String
' Función para compactar una base de datos externa
' Comprobamos si alguien está conectado a la base de datos. Simplemente miramos si existe el laccdb
If Len(Dir(Replace(strFullPath, ".accdb", ".laccdb"), vbArchive)) > 0 Then
' Parece bloqueado
MsgBox "La base de datos está en uso. Espere a que sea liberada para poder compactarla.", vbExclamation, cStrTitMb
Exit Function
End If
strNewNombre = Replace(strFullPath, ".accdb", "_Backup.accdb")
If Len(Dir(strNewNombre, vbArchive)) > 0 Then
' Borramos backup previo
Kill strNewNombre
End If
DBEngine.CompactDatabase DamePathCompletoDatos, strNewNombre
' Borramos el BackEnd
Kill strFullPath
' Renombramos el backup
Name strNewNombre As strFullPath
ExitProcedure:
On Error GoTo 0
Exit Function
ErrorHandler:
Select Case Err.Number
Case 0
Case Else
MsgBox "Error " & Err.Number & " - " & Err.Description & vbNewLine & _
"Procedimiento: CompactarOtraBDD" & vbNewLine & _
"Módulo: " & Application.VBE.ActiveCodePane.CodeModule.Name, vbCritical, "AVISO"
Resume ExitProcedure
End Select
End Function
Sub cmdAddProp_Click()
Dim intX As Integer
Const DB_Text As Long = 10
intX = AddAppProperty("AppTitle", DB_Text, "My Custom Application")
intX = AddAppProperty("AppIcon", DB_Text, "C:\Windows\Cars.bmp")
CurrentDb.Properties("UseAppIconForFrmRpt") = 1
Application.RefreshTitleBar
End Sub
Function AddAppProperty(strName As String, _
varType As Variant, varValue As Variant) As Integer
Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo AddProp_Err
dbs.Properties(strName) = varValue
AddAppProperty = True
AddProp_Bye:
Exit Function
AddProp_Err:
If Err = conPropNotFoundError Then
Set prp = dbs.CreateProperty(strName, varType, varValue)
dbs.Properties.Append prp
Resume
Else
AddAppProperty = False
Resume AddProp_Bye
End If
End Function
' ****************************************************************************
' Versión: 1.000
' Fecha última modificación: 02/09/2019
' Propósito: Averiguar si existe módulo y/o procedimiento
' ****************************************************************************
' Ver final del módulo para historial de versiones
' ****************************************************************************
Function ExisteModulo(strModule As String) As Boolean
On Error GoTo ErrorHandler
Dim mdl As AccessObject
For Each mdl In CurrentProject.AllModules
If mdl.Name = strModule Then
ExisteModulo = True
Exit Function
End If
Next
ExisteModulo = False
ExitProcedure:
On Error GoTo 0
Exit Function
ErrorHandler:
Select Case Err.Number
Case 0
Case Else
MsgBox "Error " & Err.Number & "-" & Err.Description
Resume ExitProcedure
End Select
End Function
Function ExisteProcedimiento(strModule As String, strProcedureName As String) As Boolean
On Error GoTo ErrorHandler
Dim mdl As Module
Dim lngSLine As Long
Dim lngSCol As Long
Dim lngELine As Long
Dim lngECol As Long
Dim strLine As String
Dim strNewLine As String
Dim intChr As Integer
Dim intBefore As Integer
Dim intAfter As Integer
Dim strLeft As String
Dim strRight As String
If ExisteModulo(strModule) Then
Set mdl = Modules(strModule)
Else
ExisteProcedimiento = False
End If
If mdl.Find(strProcedureName, lngSLine, lngSCol, lngELine, lngECol) Then
ExisteProcedimiento = True
Else
ExisteProcedimiento = False
End If
Set mdl = Nothing
ExitProcedure:
On Error GoTo 0
Exit Function
ErrorHandler:
Select Case Err.Number
Case 0
Case 7961
' No parece que podamos acceder a él
DoCmd.OpenModule strModule
Resume
Case Else
MsgBox "Error " & Err.Number & "-" & Err.Description
Resume ExitProcedure
End Select
End Function
' ***************** HISTORIAL ******************** HISTORIAL ******************** HISTORIAL ******************** HISTORIAL ********************
' Fecha Versión Procedimiento Descripción
' ---------- ------- ----------------------- --------------------------------------------------------------------------------------------------
' 02/09/2019 1.001 Primera versión documentada
Option Compare Database
Option Explicit
' Definimos las bibliotecas a utilizar
#Const UseObjectLibrary_XLS = True
#Const UseObjectLibrary_OLK = True
#Const UseObjectLibrary_FSO = False
#Const UseObjectLibrary_MSO = False
' ################################################## EXCEL
#If UseObjectLibrary_XLS Then
Public Const blnUseObjectLibrary_XLS As Boolean = True
Public xlsApp As Excel.Application
#Else
Public Const blnUseObjectLibrary_XLS As Boolean = False
Public xlsApp As Object
Public Const xlVeryHidden = 2
Public Const xlPrintNoComments = -4142
Public Const xlLandscape = 2
Public Const xlAutomatic = -4105
Public Const xlDownThenOver = 1
Public Const xlPrintErrorsDisplayed = 0
Public Const xlDelimited = 1
Public Const xlTextQualifierDoubleQuote = 1
Public Const xlWorkbookDefault = 51
Public Const xlOpenXMLWorkbook = 51
' Validaciones de datos
Public Const xlValidateList = 3
Public Const xlValidateDecimal = 2
Public Const xlValidAlertStop = 1
Public Const xlGreaterEqual = 7
Public Const xlBetween = 1
' Bordes
Public Const xlEdgeLeft = 7
Public Const xlEdgeTop = 8
Public Const xlEdgeBottom = 9
Public Const xlEdgeRight = 10
Public Const xlContinuous = 1
Public Const xlColorIndexAutomatic = -4105
Public Const xlHairline = 1
Public Const xlMedium = -4138
Public Const xlThick = 4
Public Const xlThin = 2
#End If
' ################################################## OUTLOOK
#If UseObjectLibrary_OLK Then
Public Const blnUseObjectLibrary_OUT As Boolean = True
Public olkApp As Outlook.Application
Public olkNs As Outlook.Namespace
Public olkFolder As Outlook.Folder
Public olkItems As Outlook.Items
Public olkRestrictedItems As Outlook.Items
Public olkMailItem As Outlook.MailItem
Public olkPrp As Outlook.UserProperty
Public olkAccount As Outlook.Account
Public olkAttach As Outlook.Attachment
#Else
Public Const blnUseObjectLibrary_OUT As Boolean = False
Public olkApp As Object
Public olkNs As Variant
Public olkFolder As Object
Public olkMail As Variant
Public olkPrp As Variant
Public olkAccount As Variant
Public olkAttach As Variant
Public Const olMailItem = 0
Public Const olMSG = 3
Public Const olByValue = 1
Public Const olByReference = 4
Public Const olFormatPlain = 1
Public Const olFormatHTML = 2
#End If
' ################################################## Microsoft Scripting Runtime
#If UseObjectLibrary_FSO Then
Public fso As Scripting.FileSystemObject
Public fsoFile As File
Public fsoDrive As Drive
#Else
Public fso As Object
Public fsoFile As Object
Public fsoDrive As Object
Public Const ForReading = 1
#End If
' ################################################## Microsoft Office x.xx
' La Object Library en los FileDialog
#If UseObjectLibrary_MSO Then
Public fDialog As Office.FileDialog
#Else
Public fDialog As Object
Public Const msoFileDialogOpen = 1
Public Const msoFileDialogSaveAs = 2
Public Const msoFileDialogFilePicker = 3
Public Const msoFileDialogFolderPicker = 4
#End If
f = FreeFile
Open Me!PathA1 For Input As #f
linea = 0
Do Until EOF(f)
Line Input #f, strLineaIn
linea = linea + 1
Loop
Close #f
lngTotalRegistros = linea
Function fntDameLineasFichero(ByVal strRuta As String) As Long
Dim f As Integer
Dim strTexto As String
Dim arrLineas() As String
f = FreeFile
Open strRuta For Input As #f
strTexto = Input(LOF(f), #f)
Close #f
arrLineas = Split(strTexto, vbNewLine)
fntDameLineasFichero = UBound(arrLineas) - LBound(arrLineas) + 1
Erase arrLineas
End Function
Cita de: Mihura
Para crearte una mdb desde Excel basta con usar el siguiente módulo:
Private Sub RT_CreateDatabase(NombreBD As String)
'Creamos una database con ADO, tiene que estar referenciada la libreria Microsoft ActiveX Data Objects (yo suelo usar la 2.8)
Dim Catalog As Object
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & NombreBD & ";"
Set Catalog = Nothing
End Sub
Cita de: Emilio
Utilizando:
Catalog.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & NombreBD & ";"
podremos crear una en formato 2007-2010 (accdb)