'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