'Test Resume/Resume 0
Sub ControlErrores_Resume0()
Dim resultado As String
Dim strSQL As String
On Error GoTo LinErr
resultado = DLookup("[texto]", "test", "[idtest]=5")
Debug.Print resultado
Exit Sub
LinErr:
DoCmd.SetWarnings False
strSQL = "INSERT INTO test(idtest, texto,Numero) VALUES(5,'Producto 5' ,234.58)"
DoCmd.RunSQL strSQL
Resume
End Sub
'Test Resume Etiqueta
'---------------------------------------------------------------------------------------
' Procedure : FSO_FileCopy
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Copy a file
' Overwrites existing copy without prompting (you can change the varible
' in the CopyFile method call)
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
' (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Uses Late Binding, so none required
' Ref : FSO - https://msdn.microsoft.com/en-us/library/ms127964(v=vs.110).aspx
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sSource - Path/Name of the file to be copied
' sDest - Path/Name for copying the file to
'
' Usage:
' ~~~~~~
' FSO_FileCopy("C:\TE.MP\Tab.le1.txt", "C:\TE.MP\Tab.le3.txt")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2018-06-16 Initial Release - Blog Help
'---------------------------------------------------------------------------------------
Public Function FSO_FileCopy(ByVal sSource As String, _
ByVal sDest As String) As Boolean
On Error GoTo Error_Handler
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Call oFSO.CopyFile(sSource, sDest, True)
FSO_FileCopy = True
Error_Handler_Exit:
On Error Resume Next
If Not oFSO Is Nothing Then Set oFSO = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: FSO_FileCopy" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
'Test Resume Next
Sub test()
Dim strPathNameNew As String
strPathNameNew = Application.CurrentProject.Path & "\Destellos_Online.accdb"
Call mcBeginProperties(strPathNameNew)
End Sub
Public Sub mcBeginProperties(ByVal strPathNamedbs As String)
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/tratamiento-de-errores-resume/
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : mcBeginProperties
' Autor : Rafael .:McPegasus:. for BeeSoftware.
' Actualizado : 11/08/2022
' Propósito : En el momento de crear un accde, entre otros, ejecuto este procedimiento con el fin de establecer el valor de las diferentes propiedades de inicio que tiene Microsoft Access por ejemplo AllowSpecialKeys, StartupForm entre otras. De este modo el programa se comporta más hermético tras crear un accde.
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Argumentos : La sintaxis del procedimiento o función consta de los siguientes argumentos:
' Parte Modo Descripción
' --------------------------------------------------------------------------------------------------------------------------
' strPathNamedbs Obligatorio El valor String especifica la ruta completa de la base de datos a modificar los valores.
'-----------------------------------------------------------------------------------------------------------------------------------------------
Dim strNameProperty As String
On Error GoTo Err_CapturarError
'Mostrar fichas de documentos.
strNameProperty = "ShowDocumentTabs"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, True)
'Permitir el uso de menús no restringidos.
strNameProperty = "AllowFullMenus"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Permitir el uso de menús contextuales predeterminados.
strNameProperty = "AllowShortcutMenus"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Permitir mostrar código después de un error
strNameProperty = "AllowBreakIntoCode"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Mostrar el formulario de inicio
strNameProperty = "StartupForm"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, True)
'Mostrar la banda de opciones
' strNameProperty = "CustomRibbonID"
' Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, True)
'Presentar la ventana Base De Datos al Iniciar.
strNameProperty = "StartUpShowDBWindow"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Presentar la Barra de Estado.
strNameProperty = "StartUpShowStatusBar"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Permitir el uso de las barras de herramientas incorporadas.
strNameProperty = "AllowBuiltInToolbars"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Permitir cambios en barras de herramientas y menús.
strNameProperty = "AllowToolbarChanges"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Usar las teclas especiales de Access.
strNameProperty = "AllowSpecialKeys"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
'Permitir Ignorar Inicio (Activar la tecla shift)
strNameProperty = "AllowBypassKey"
Call mcBeginPropertiesII(strPathNamedbs, strNameProperty, False)
Salida:
Exit Sub
Err_CapturarError:
Select Case Err.Number
Case Else
'Cazar todos aquellos errores inesperados.
MsgBox Err.Number & " " & Err.Description, vbCritical, "En mcBeginProperties."
End Select
Resume Salida 'Salida a otro procedimiento.
End Sub
Private Sub mcBeginPropertiesII(ByVal strPathNamedbs As String, ByVal strNameProperty As String, ByVal blnTrue As Boolean)
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/tratamiento-de-errores-resume/
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : mcBeginPropertiesII
' Autor : Rafael .:McPegasus:. for BeeSoftware.
' Actualizado : 10/06/207
' Propósito : De las propiedades de inicio que tiene Microsoft Access, modificar la pasada por parámetro.
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Argumentos : La sintaxis del procedimiento o función consta de los siguientes argumentos:
' Parte Modo Descripción
' --------------------------------------------------------------------------------------------------------------------------
' strPathNamedbs Obligatorio El valor String especifica la ruta completa de la base de datos a modificar los valores.
' strNameProperty Obligatorio El valor String especifica el nombre de la propiedad a modificar su valor.
' blnTrue Obligatorio El valor Boolean especifica el nuevo valor de la propiedad.
'-----------------------------------------------------------------------------------------------------------------------------------------------
Dim dbs As DAO.Database
Const cstrStartupForm As String = "Apertura"
Const cstartupRibbon As String = "MHARM"
On Error GoTo Err_CapturarError
Set dbs = OpenDatabase(strPathNamedbs, True, False)
On Error Resume Next
dbs.Properties(strNameProperty) = blnTrue
On Error GoTo 0
If strNameProperty = "StartupForm" Then
dbs.Properties.Append dbs.CreateProperty(strNameProperty, dbText, cstrStartupForm)
End If
' If strNameProperty = "CustomRibbonID" Then
' dbs.Properties.Append dbs.CreateProperty(strNameProperty, dbText, cstartupRibbon)
' End If
Salida:
Exit Sub
Err_CapturarError:
Select Case Err.Number
Case 3356 'Intenta abrir una dbs y está ocupada, intentar de nuevo después un breve tiempo.
Case Else
'Cazar errores inesperados.
MsgBox Err.Number & " " & Err.Description, vbCritical, "En mcBeginPropertiesII."
End Select
Resume Next
End Sub
'Ejemplo resume redundante
Function kbCopyFile(ByVal Source$, ByVal Destination$) As Long
Dim Index1 As Integer, NumBlocks As Integer
Dim SourceFile As Integer, DestFile As Integer
Dim FileLength As Long, LeftOver As Long, AmountCopied As Long
Dim FileData As String
Const BlockSize = 32768
On Error GoTo Err_kbCopyFile
' Remove the destination file.
DestFile = FreeFile
Open Destination For Output As DestFile
Close DestFile
' Open the source file to read from.
SourceFile = FreeFile
Open Source For Binary Access Read As FreeFile
' Open the destination file to write to.
DestFile = FreeFile
Open Destination For Binary As DestFile
' Get the length of the source file.
FileLength = LOF(SourceFile)
' Calculate the number of blocks in the file and left over.
NumBlocks = FileLength \ BlockSize
LeftOver = FileLength Mod BlockSize
' Create a buffer for the leftover amount.
FileData = String$(LeftOver, 32)
' Read and write the leftover amount.
Get SourceFile, , FileData
Put DestFile, , FileData
' Create a buffer for a block to be read.
FileData = String$(BlockSize, 32)
' Read and write the remaining blocks of data.
For Index1 = 1 To NumBlocks
' Read and write one block of data.
Get SourceFile, , FileData
Put DestFile, , FileData
Next Index1
Close SourceFile, DestFile
kbCopyFile = AmountCopied
Bye_kbCopyFile:
Exit Function
Err_kbCopyFile:
kbCopyFile = -1 * Err
Resume Bye_kbCopyFile
End Function
