VBA Access. Redondeo de números decimales con el método medio redondeo. Alternativa a la función Round (bankers round)

 Private Function Redondeo(ByVal Numero As Variant, ByVal Decimales As Integer) As Double

    'Aplica método medio redondeo (half round up) Redondeo(23.345,2) = 23.35.

    'Es diferente que el de la funcion Round de access (bankers rounding) Round(23.345,2) = 23.34

    

    Dim dbl As Double

    dbl = CDec(Nz(Numero))

    dbl = CDec(dbl * 10 ^ Decimales)

    Redondeo = Fix(dbl + 0.5 * Sgn(Numero)) / 10 ^ Decimales

End Function

Microsoft Sql Server. Crear un alias. Aunar el nombre y el puerto de un servidor sql en un alias. Ej. srvql,10001 -> alias SERVIDOR

En las herramientas de configuración del Sql crearemos el alias

Una vez configurado el alias este se podrá usar sin tener que indicar el puerto.

En el ejemplo hemos creado un alias sobre srvsql,10051 equivale a SERVIDOR (nombre del alias) 

VBA Access. Módulo para combinar ficheros de texto.

Option Compare Database
Option Explicit

'   Requisitos:
'*  Referencia VBA Microsoft Scripting Runtime (filesystemobject)

Public Function MergeTXTs(ByRef aFiles() As String, ByVal OutputFile As String, Optional ByVal bIncluirNombreInicio As Boolean, Optional ByVal bIncluirNombreFinal As Boolean, Optional ByVal txtFinalFichero As String = "") As Boolean
On Error GoTo error
    Dim fso As New FileSystemObject
   
    Dim i As Integer
    Dim File As Variant
   
 
    Dim TmpFolder As String

    TmpFolder = CurrentProject.Path & "\Temp\" & GetWindowsUser
    If Not fso.FolderExists(TmpFolder) Then MakeDirFullPath TmpFolder
   
    DoCmd.Hourglass True
   
    Dim sAllLinesFiles As String
    For i = 0 To UBound(aFiles)
        Debug.Print "file " & i & ": " & aFiles(i)
        sAllLinesFiles = sAllLinesFiles & _
        IIf(Nz(sAllLinesFiles, "") <> "", vbCrLf, "") & _
        IIf(bIncluirNombreInicio, "-- " & DimeNombreFichero(aFiles(i)) & " --" & vbCrLf, "") & _
        ReadTxt(aFiles(i)) & _
        IIf(bIncluirNombreFinal, vbCrLf & "-- " & DimeNombreFichero(aFiles(i)) & " --", "") & _
        IIf(txtFinalFichero <> "", vbCrLf & txtFinalFichero, "")
    Next
 
    MergeTXTs = WriteTxt(OutputFile, sAllLinesFiles)
    Set fso = Nothing

    SysCmd acSysCmdClearStatus
    DoCmd.Hourglass False

Exit Function
Resume
error:
    DoCmd.Hourglass False
    MergeTXTs = False
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

Public Function MakeDirFullPath(ByVal sPath As String) As Boolean
On Error GoTo error
    'crear todo el path de un directorio
    If Right(sPath, 1) = "\" Then
        sPath = Left(sPath, Len(sPath) - 1)
    End If
    Dim SplitPath() As String
    SplitPath = Split(sPath, "\")
    Dim Value As Integer
    Dim Merge As String
    For Value = 0 To UBound(SplitPath)
        If Value <> 0 Then
            Merge = Merge & "\"
        End If
        Merge = Merge & SplitPath(Value)
        If Dir(Merge, vbDirectory) = "" Then
            MkDir Merge
        End If
    Next
    SetAttr sPath, vbNormal
    MakeDirFullPath = True
 
Exit Function
error:
    MakeDirFullPath = False
    Debug.Print Err.Description
End Function

Public Function DimeNombreFichero(ByVal sFichero As String) As String
On Error GoTo error
    Dim fso As New FileSystemObject
    If Not fso.FileExists(sFichero) Then Exit Function
   
    DimeNombreFichero = fso.GetFileName(sFichero)
    Set fso = Nothing

Exit Function
error:
    DimeNombreFichero = ""
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

Public Function GetWindowsUser() As String
On Error GoTo error
    Dim sUsername As String
    Dim objNetwork As Object
 
    sUsername = Environ$("username")
 
    If sUsername = "" Then
        Set objNetwork = CreateObject("WScript.Network")
        sUsername = objNetwork.UserName
        Set objNetwork = Nothing
    End If

    GetWindowsUser = sUsername
 
Exit Function
error:
    Debug.Print Err.Description
    GetWindowsUser = ""
End Function

Public Function WriteTxt(ByVal sPathFileName As String, ByVal sValue As String, Optional ByVal bAppend As Boolean = False) As Boolean
On Error GoTo error
    Dim SFName As String    'ruta y nombre completo del fichero de texto
    Dim iFNumber As Integer

    SFName = sPathFileName

    'crear la ruta completa si no existe
    MakeDirFullPath (Left(SFName, InStrRev(SFName, "\") - 1))

    'obtener numero de fichero
    iFNumber = FreeFile

    'añadir o sobreescribir el fichero
    If bAppend Then
        Open SFName For Append As #iFNumber
    Else
        Open SFName For Output As #iFNumber
    End If

    Print #iFNumber, sValue
    Close #iFNumber

    WriteTxt = True

Exit Function
error:
    WriteTxt = False
    Debug.Print Err.Description
End Function

Public Function ReadTxt(ByVal sPathFileName As String) As String
On Error GoTo error
    Dim sLines, sLine As String
    Dim iFile As Integer: iFile = FreeFile
    Open sPathFileName For Input As #iFile
    Do Until EOF(1)
        Line Input #1, sLine
        sLines = sLines & IIf(Nz(sLines, "") <> "", vbCrLf, "") & sLine
    Loop
    Close #iFile
    ReadTxt = sLines

Exit Function
error:
    ReadTxt = ""
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

VBA Access. Módulo para combinar PDF con GhostScript (Merge PDF).

Option Compare Database
Option Explicit

'   Requisitos:
'*  Referencia VBA Microsoft Scripting Runtime (filesystemobject)
'*  Postscript and PDF interpreter/renderer (GhostScript)
'   Descargar de https://www.ghostscript.com/ En este ejemplo se usa la version gs9.50 x64

'MaxFiles = 114. Según las pruebas, 114 es el número máximo de ficheros que es capaz de combinar la versión Ghostscript gs9.50 x64 <<< MergePDFs no tiene ese límite >>>
'Si se supera el máximo, el programa no da error, el PDF es legible pero no contendrá todos los ficheros a combinar
'En caso de usar otra versión de GhostScript se deberá ajustar MaxFiles y comprobar si la salida del PDF es correcta

'La función MergePDFs puede superar el máximo permitido de combinación (MaxFiles), mediante el uso de ficheros pdf temporales, que en el último paso se combinan en 1 solo.
'El máximo teórico de ficheros pdf posibles a combinar seria 114x114 = 12996 ficheros.
'En una de las pruebas se ha conseguido combinar más de 800 ficheros con el resultado de 1 pdf combinado de más de 30000 páginas y 1 hora aprox. de proceso

'Ejemplos de uso:
'>> sin mostrar progreso de ghostscript
'MergePDFs aFiles, txtFicheroSalida
'>> mostrando progreso de ghostscript
'MergePDFs aFiles, txtFicheroSalida, True

Public Const MAXFILES = 114

Public Function MergePDFs(ByRef aFiles() As String, ByVal OutputFile As String, ByVal FicheroExeGS As String, Optional FolderFonts As String = "", Optional bMostrarProgreso As Boolean = False, Optional bMantenerCalidad As Boolean = True, Optional ByVal MAXTEMPFILES As Integer = MAXFILES) As Boolean
On Error GoTo error
    Dim fso As New FileSystemObject
 
    Dim iFile, i, nTempFiles
    Dim File As Variant
 
    Dim PdfFiles As String
    Dim aPdfFiles() As String
 
    Dim TmpFolder As String
    Dim PdfTemp As String
    Dim aPdfTemps() As String
 
    If Not fso.FileExists(FicheroExeGS) Then
        MsgBox "No se ha encontrado el fichero ejecutable GhostScript '" & FicheroExeGS & "'", vbExclamation, ""
        MergePDFs = False
        GoTo Salir
    End If
 
    TmpFolder = CurrentProject.Path & "\Temp\" & GetWindowsUser
    If Not fso.FolderExists(TmpFolder) Then MakeDirFullPath TmpFolder
 
    DoCmd.Hourglass True
 
    'Creamos tantos ficheros temporales combinados como sean necesarios (máximo MaxFiles combinados por fichero temporal)
    iFile = 1
    nTempFiles = 0
    For i = 0 To UBound(aFiles)
        'construimos lista de ficheros a combinar en un fichero temporal para pasar como parametro a GhostScript
        If iFile <= MAXTEMPFILES Then
            PdfFiles = IIf(PdfFiles <> "", PdfFiles & " " & """" & aFiles(i) & """", """" & aFiles(i) & """")
        End If
     
        'si llega al máximo de ficheros temporales o al último de los ficheros, creamos el fichero pdf temporal
        If iFile = MAXTEMPFILES Or i = UBound(aFiles) Then
            PdfTemp = TmpFolder & "\gsTmp_" & nTempFiles & ".pdf"
         
            'guardamos la lista de ficheros temporales creados en un array de strings
            ReDim Preserve aPdfTemps(nTempFiles)
            aPdfTemps(nTempFiles) = PdfTemp
            nTempFiles = nTempFiles + 1
         
            SysCmd acSysCmdSetStatus, "Combinando " & iFile & " ficheros a fichero temporal '" & PdfTemp & "'"
            MergePDFs = RunGhostScript(PdfFiles, PdfTemp, FicheroExeGS, FolderFonts, bMostrarProgreso, bMantenerCalidad)
            If Not MergePDFs Then GoTo Salir
         
            'reiniciamos lista de ficheros a combinar
            iFile = 0
            PdfFiles = ""
        End If
        iFile = iFile + 1
    Next
 
    If fso.FileExists(OutputFile) Then fso.DeleteFile (OutputFile)
    'Combinamos todos los ficheros temporales en el fichero de salida
    If UBound(aPdfTemps) > 0 Then
        'construimos la lista de ficheros a combinar para pasar como parametro a GhostScript. Los ficheros a combinar son el array donde tenemos almacenados los pdf temporales creados.
        PdfFiles = ""
        For i = 0 To UBound(aPdfTemps)
            PdfFiles = IIf(PdfFiles <> "", PdfFiles & " " & """" & aPdfTemps(i) & """", """" & aPdfTemps(i) & """")
        Next
     
        SysCmd acSysCmdSetStatus, "Combinando " & i & " ficheros temporales a fichero final '" & OutputFile & "'"
        MergePDFs = RunGhostScript(PdfFiles, OutputFile, FicheroExeGS, FolderFonts, bMostrarProgreso, bMantenerCalidad)
     
        'eliminar ficheros temporales
        For i = 0 To UBound(aPdfTemps)
            fso.DeleteFile aPdfTemps(i)
        Next
    Else
        'Solo hay 1 fichero temporal. No hace falta combinar, movemos/renombramos el fichero como fichero de salida
        fso.MoveFile aPdfTemps(0), OutputFile
    End If
 
Salir:
    Set fso = Nothing

    SysCmd acSysCmdClearStatus
    DoCmd.Hourglass False

Exit Function
Resume
error:
    DoCmd.Hourglass False
    MergePDFs = False
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

Private Function RunGhostScript(ByVal PdfFiles As String, ByVal OutputFile As String, ByVal FicheroExeGS As String, Optional FolderFonts As String = "", Optional bMostrarProgreso As Boolean = False, Optional bConsolaBlanca As Boolean = True, Optional bMantenerCalidad As Boolean = True) As Boolean
On Error GoTo error
    Dim res As Integer
    Dim wsh As Object
    Dim windowStyle As Integer
    Dim waitOnReturn As Boolean

    Dim gsCmd As String
 
    If bMantenerCalidad Then
        gsCmd = """" & FicheroExeGS & """" & IIf(bMostrarProgreso, "", " -q") & IIf(FolderFonts <> "", " -sFONTPATH=""" & FolderFonts & """ -dEmbedAllFonts=true", "") & _
        " -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -dAutoRotatePages=/None -dAutoFilterColorImages=false -dAutoFilterGrayImages=false -dColorImageFilter=/FlateEncode" & _
        " -dGrayImageFilter=/FlateEncode -dDownsampleMonoImages=false -dDownsampleGrayImages=false -sOutputFile=""" & OutputFile & """" & " " & PdfFiles
    Else
        gsCmd = """" & FicheroExeGS & """" & IIf(bMostrarProgreso, "", " -q") & IIf(FolderFonts <> "", " -sFONTPATH=""" & FolderFonts & """ -dEmbedAllFonts=true", "") & _
        " -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=""" & OutputFile & """" & " " & PdfFiles
    End If

    'windowStyle: 0 oculta ventana shell, 1 muestra ventana shell
    windowStyle = IIf(bMostrarProgreso, 1, 0)
    waitOnReturn = True
    Set wsh = VBA.CreateObject("WScript.Shell")
    res = wsh.Run(gsCmd, windowStyle, waitOnReturn)
    Set wsh = Nothing

    'res=0 proceso completo finalizado OK
    RunGhostScript = (res = 0)

Exit Function
error:
    DoCmd.Hourglass False
    RunGhostScript = False
    MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function

Public Function MakeDirFullPath(ByVal sPath As String) As Boolean
On Error GoTo error
    'crear todo el path de un directorio
    If Right(sPath, 1) = "\" Then
        sPath = Left(sPath, Len(sPath) - 1)
    End If
    Dim SplitPath() As String
    SplitPath = Split(sPath, "\")
    Dim Value As Integer
    Dim Merge As String
    For Value = 0 To UBound(SplitPath)
        If Value <> 0 Then
            Merge = Merge & "\"
        End If
        Merge = Merge & SplitPath(Value)
        If Dir(Merge, vbDirectory) = "" Then
            MkDir Merge
        End If
    Next
    SetAttr sPath, vbNormal
    MakeDirFullPath = True
 
Exit Function
error:
    MakeDirFullPath = False
    Debug.Print Err.Description
End Function

Public Function GetWindowsUser() As String
On Error GoTo error
    Dim sUsername As String
    Dim objNetwork As Object
 
    sUsername = Environ$("username")
 
    If sUsername = "" Then
        Set objNetwork = CreateObject("WScript.Network")
        sUsername = objNetwork.UserName
        Set objNetwork = Nothing
    End If

    GetWindowsUser = sUsername
 
Exit Function
error:
    Debug.Print Err.Description
    GetWindowsUser = ""
End Function

Microsoft Sql Server. Script para hacer backup de todas las bases de datos.

Se puede ejecutar en una consulta o bien programar con el manager del Sql mediante un trabajo en el Agente del Sql Server. Debemos tener permisos totales en la carpeta destino. Si se ejecuta mediante el Agente Sql, debemos asegurarnos que el servicio está iniciado, ponerlo en inicio automático.  Se debe dar permiso de escritura al usuario del servicio Agente Sql en la carpeta destino (mirar el en las propiedades del servicio para ver el usuario).

SET NOCOUNT ON

DECLARE @Catalogo sysname
DECLARE @StrSql as nvarchar(500)

DECLARE Catalogos CURSOR FOR SELECT Name FROM SysDatabases A WHERE A.Name<>'Tempdb' ORDER BY A.Name
OPEN Catalogos
FETCH NEXT FROM Catalogos INTO @Catalogo
WHILE @@FETCH_STATUS = 0
BEGIN
SET @StrSql='BACKUP DATABASE [' + @Catalogo + '] TO DISK = N''C:\BackupSql\' + @Catalogo + '.bak' + ''' WITH INIT, NOUNLOAD, NAME= N''Copia ' + @Catalogo + ' Diaria'',  NOSKIP ,  STATS = 100,  NOFORMAT'
EXEC (@StrSql)

FETCH NEXT FROM Catalogos INTO @Catalogo
END

CLOSE Catalogos
DEALLOCATE Catalogos

Windows. Forzar detener un servicio que no responde.

Si tienes un servicio que no responde y no lo puedes detener:

En menú Inicio, en la búsqueda escribimos "servicios" y abrimos la opción encontrada.

Localizamos el servicio y en sus propiedades observamos el nombre del servicio.

Des del menú Inicio, en búsqueda, escribimos "cmd", del resultado de la búsqueda hacemos botón derecho y seleccionamos "Ejecutar como administrador"

Escribimos: 

sc queryex "nombre del servicio" (las comillas no hay que incluirlas)

Pulsamos enter para identificar el número del proceso:  PID

Escribimos:

taskkill /pid  "número de PID" /f (no incluir las comillas)

Pulsamos enter y esto deberia parar el servicio.

Si queremos volver a arrancar el servicio podemos ir de nuevo a servicios y arrancarlo des de la interfaz.

Módulo de Visual Basic .NET para leer, grabar, editar y eliminar contenido en un fichero xml. Ejemplo completo de gestión de un fichero xml.

Imports System.IO
Imports System.Xml

Module ModCadenasConexionesXml
    'Gestionar fichero xml que almacena en este caso cadenas de conexion
    'Leer, Grabar, Editar y Eliminar valores de cadenas de conexion
    '
    'Ejemplo fichero:
    '<?xml version="1.0" encoding="utf-8"?>
    '<CadenasConexiones>
    ' <CadenaConexion ID = "1" >
    '    <Valor>Server=.\SQLEXPRESS;Database=PRUEBAS;Trusted_Connection=True;</Valor>
    ' </CadenaConexion>
    ' <CadenaConexion ID = "2" >
    '    <Valor>Server=.\SQLEXPRESS;Database=PRUEBAS2;Trusted_Connection=True;</Valor>
    ' </CadenaConexion>
    '</CadenasConexiones>

    Const PATHFICHERO = ".\CadenasConexion.xml"
    Const NOMBRERAIZ = "CadenasConexiones"
    Const NOMBRENODO = "CadenaConexion"
    Const NOMBREATRIBUTONODO1 = "ID"
    Const NOMBREVALORNODO1 = "Valor"

    Public Class clsCadenaConexion
        Public _ID As String
        Public _Valor As String

        Public Sub New()
            Me._ID = ""
            Me._Valor = ""
        End Sub

        Public Sub New(DescConexion As String, CadConexion As String)
            Me._ID = DescConexion
            Me._Valor = CadConexion
        End Sub

        Public Function GrabarCadenaConexionXml() As Boolean
            Try
                If Not File.Exists(PATHFICHERO) Then
                    'Crear XmlWriterSttings.
                    Dim settings As XmlWriterSettings = New XmlWriterSettings()
                    settings.Indent = True

                    'Crear XmlWriter
                    Dim writer As XmlWriter
                    writer = XmlWriter.Create(PATHFICHERO, settings)

                    'Inicio escritura documento xml
                    writer.WriteStartDocument()
                    writer.WriteStartElement(NOMBRERAIZ) ' Raíz.

                    'Grabar nodo
                    writer.WriteStartElement(NOMBRENODO)
                    writer.WriteAttributeString(NOMBREATRIBUTONODO1, Me._ID)
                    writer.WriteElementString(NOMBREVALORNODO1, Me._Valor)
                    'Fin grabar nodo
                    writer.WriteEndElement()

                    'Fin escritura documento xml
                    writer.WriteEndElement()
                    writer.Close()
                Else
                    ActualizarGrabarNodo()
                End If

                Return True

            Catch ex As Exception
                Debug.Print(ex.Message)
                Return False
            End Try
        End Function

        Private Function ActualizarGrabarNodo() As Boolean
            Dim resb As Boolean = False

            Try
                'Cargar fichero xml
                Dim xd As New XmlDocument
                xd.Load(PATHFICHERO)

                'Buscar NODO por el atributo ID
                For Each e As XmlElement In xd.GetElementsByTagName(NOMBRENODO)
                    resb = (Me._ID = e.GetAttribute(NOMBREATRIBUTONODO1))
                    If resb Then
                        'ID encontrado. Actualizar valor
                        e.Item(NOMBREVALORNODO1).InnerText = Me._Valor
                        xd.Save(PATHFICHERO)
                        Exit For
                    End If
                Next e

                If Not resb Then
                    'ID no encontrado. Grabar nuevo valor

                    'Creamos nuevo nodo con sus atributos y elementos
                    Dim nCadCon As XmlElement = xd.CreateElement(NOMBRENODO)
                    nCadCon.SetAttribute(NOMBREATRIBUTONODO1, Me._ID)
                    Dim nValor As XmlElement = xd.CreateElement(NOMBREVALORNODO1)
                    nValor.InnerText = Me._Valor
                    nCadCon.AppendChild(nValor)

                    'Añadir nuevo nodo al xml y grabar los cambios al fichero
                    xd.DocumentElement.AppendChild(nCadCon)
                    xd.Save(PATHFICHERO)

                    resb = True
                End If

                Return resb
            Catch ex As Exception
                Debug.Print(ex.Message)
                Return False
            End Try

        End Function

        Public Function EliminarCadenaConexionXml() As Boolean
            Dim resb As Boolean = False

            Try
                'Cargar fichero xml
                Dim xd As New XmlDocument
                xd.Load(PATHFICHERO)

                'Buscar NODO por ID
                For Each e As XmlElement In xd.GetElementsByTagName(NOMBRENODO)
                    resb = (Me._ID = e.GetAttribute(NOMBREATRIBUTONODO1))
                    If resb Then
                        'ID encontrado. Eliminar NODO
                        'obtenemos el nodo del elemento
                        Dim xn As XmlNode = e
                        'obtenemos la raiz e indicamos borrar el nodo
                        xn.ParentNode.RemoveChild(xn)
                        'grabamos los cambios en el fichero xml
                        xd.Save(PATHFICHERO)

                        Exit For
                    End If
                Next e

                Return resb
            Catch ex As Exception
                Debug.Print(ex.Message)
                Return False
            End Try

        End Function

        Public Function LeerCadenasConexionesXml() As DataSet
            Try
                Dim ds As New DataSet
                ds.Tables().Add(NOMBRERAIZ)
                ds.Tables(NOMBRERAIZ).Columns.Add(NOMBREATRIBUTONODO1)
                ds.Tables(NOMBRERAIZ).Columns.Add(NOMBREVALORNODO1)

                Dim xd As New XmlDocument
                xd.Load(PATHFICHERO)

                For Each e As XmlElement In xd.GetElementsByTagName(NOMBRENODO)
                    Dim dr As DataRow
                    dr = ds.Tables(NOMBRERAIZ).Rows.Add
                    dr(NOMBREATRIBUTONODO1) = e.GetAttribute(NOMBREATRIBUTONODO1)
                    dr(NOMBREVALORNODO1) = e.Item(NOMBREVALORNODO1).InnerText
                    dr.AcceptChanges()
                Next e

                Return ds

            Catch ex As Exception
                Debug.Print(ex.Message)
                Return Nothing
            End Try
        End Function

    End Class

End Module

VBA Access. Función para visualizar o imprimir informes que se encuentran en un archivo externo. Consigue evitar error si el informe ya está abierto.

#If Win64 = 1 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Public Function ImprimirReport(ByVal sPathFileReports As String, ByVal Report As String, Optional ByVal OpenArgs As String = "", Optional VistaPrevia As Boolean = False) As Boolean
On Error GoTo Error:
    Dim bReintento As Boolean
    bReintento = False
       
    Dim objAccess As Access.Application
    Set objAccess = GetObject(sPathFileReports)
   
    If VistaPrevia Then
        objAccess.Visible = True
    Else
        objAccess.Visible = False
    End If
   
Retry:
    objAccess.DoCmd.Close acReport, Report
    objAccess.DoCmd.OpenReport Report, IIf(VistaPrevia, acViewPreview, acViewNormal), , , , OpenArgs
   
    If Not VistaPrevia Then
        Sleep 10
       
        objAccess.DoCmd.Close acReport, Report
        objAccess.Application.Quit
        Set objAccess = Nothing
    End If
   
    ImprimirReport = True
   
Exit Function
    Resume
Error:
    If Not bReintento And Err.Number = 2455 Then
        'Si el archivo de reports ya se encuentra abierto,
        'no es posible cambiar la propiedad Visible y lanza el error 2455
        'continuar desde etiqueta Retry.
        'USAMOS EL FLAG bReintento PARA REINTENTAR SOLO 1 VEZ.
        bReintento = True
        GoTo Retry
    End If

    If Not objAccess Is Nothing Then objAccess.Application.Quit
    Set objAccess = Nothing
    ImprimirReport = False
    MsgBox Err.Number & ": " & Err.Description
End Function

VBA Access. Módulo para substituir SendKeys usando el API de Windows para evitar el conocido bug de SendKeys con el NumLock.

Option Compare Database
Option Explicit

'Ej tecla ESCAPE: EnviarTeclas VK_ESCAPE
'Ej tecla ESCAPE 2 veces: EnviarTeclas VK_ESCAPE , , 2
'Ej teclas CTRL+C: EnviarTeclas VK_CONTROL,vbKeyC
'Ej teclas ALT+SPACE: EnviarTeclas VK_MENU,VK_SPACE
'Ej teclas ALT+G: EnviarTeclas VK_MENU, vbKeyG
'Ej teclas SHIFT+DEL: EnviarTeclas VK_SHIFT, VK_DELETE

Const KEYEVENTF_KEYUP = &H2
Const KEYEVENTF_EXTENDEDKEY = &H1

'-----------------
'Virtual Key Codes
'-----------------

'VK_LBUTTON The left mouse button
'VK_RBUTTON The right mouse button
'VK_CANCEL The Cancel virtual key, used for control-break processing
'VK_MBUTTON The middle mouse button
'VK_BACK Backspace
'VK_TAB Tab
'VK_CLEAR 5 (keypad without Num Lock)
'VK_RETURN Enter
'VK_SHIFT Shift (either one)
'VK_CONTROL Ctrl (either one)
'VK_MENU Alt (either one)
'VK_PAUSE Pause
'VK_CAPITAL Caps Lock
'VK_ESCAPE Esc
'VK_SPACE Spacebar
'VK_PRIOR Page Up
'VK_NEXT Page Down
'VK_END End
'VK_HOME Home
'VK_LEFT Left Arrow
'VK_UP Up Arrow
'VK_RIGHT Right Arrow
'VK_DOWN Down Arrow
'VK_SELECT Select
'VK_PRINT Print (only used by Nokia keyboards)
'VK_EXECUTE Execute (Not used)
'VK_SNAPSHOT Print Screen
'VK_INSERT Insert
'VK_DELETE Delete
'VK_HELP Help

'Constant Definitions

Public Const VK_LBUTTON = &H1
Public Const VK_RBUTTON = &H2
Public Const VK_CANCEL = &H3
Public Const VK_MBUTTON = &H4
Public Const VK_BACK = &H8
Public Const VK_TAB = &H9
Public Const VK_CLEAR = &HC
Public Const VK_RETURN = &HD
Public Const VK_SHIFT = &H10
Public Const VK_CONTROL = &H11
Public Const VK_MENU = &H12
Public Const VK_PAUSE = &H13
Public Const VK_CAPITAL = &H14
Public Const VK_ESCAPE = &H1B
Public Const VK_SPACE = &H20
Public Const VK_PRIOR = &H21
Public Const VK_NEXT = &H22
Public Const VK_END = &H23
Public Const VK_HOME = &H24
Public Const VK_LEFT = &H25
Public Const VK_UP = &H26
Public Const VK_RIGHT = &H27
Public Const VK_DOWN = &H28
Public Const VK_SELECT = &H29
Public Const VK_PRINT = &H2A
Public Const VK_EXECUTE = &H2B
Public Const VK_SNAPSHOT = &H2C
Public Const VK_INSERT = &H2D
Public Const VK_DELETE = &H2E
Public Const VK_HELP = &H2F

#If Win64 = 1 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

#If Win64 = 1 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Public Function EnviarTeclas(Key1 As Long, Optional Key2 As Long = 0, Optional NumRepeticiones = 1) As Boolean
On Error GoTo error
    Dim i As Integer
 
    For i = 1 To NumRepeticiones
        Call keybd_event(Key1, 0, 0, 0)
        If Key2 <> 0 Then Call keybd_event(Key2, 0, 0, 0)
     
        Sleep 10
        DoEvents
     
        Call keybd_event(Key1, 0, KEYEVENTF_KEYUP, 0)
        If Key2 <> 0 Then Call keybd_event(Key2, 0, KEYEVENTF_KEYUP, 0)
     
        Sleep 10
        DoEvents
    Next i
 
    EnviarTeclas = True
 
Exit Function
error:
    Debug.Print Err.Number & ": " & Err.Description
    EnviarTeclas = False
End Function

VBA Access. Módulo para Leer valores de ficheros de configuración.

'Ejemplos der uso:
'Contenido FicheroTxt1:
'CLAVE1=VALOR1;CLAVE2=VALOR2
'ObtenerValorClave(ContenidoFicheroTxt,"CLAVE1","=",";") => VALOR1

'Contenido FicheroTxt2:
'CLAVE1=VALOR1
'CLAVE2=VALOR2

' ObtenerValorClave(ContenidoFicheroTxt,"CLAVE2","=",vbCrLf) => VALOR2

Public Function ObtenerValorClave(ByVal sValores As String, ByVal sClave As String, ByVal sCarIniClave, ByVal sCarFinClave) As String
On Error GoTo error
    Dim PosIni As Integer
    Dim PosFin As Integer
    Dim sValor As String

    PosIni = GetPosValue(UCase(sValores), UCase(sClave), sCarIniClave)
    PosFin = GetPosValue(UCase(sValores), UCase(sClave), sCarFinClave)
    sValor = GetValue(sValores, PosIni, PosFin)
    ObtenerValorClave = sValor

Exit Function
error:
    ObtenerValorClave = ""
    Debug.Print Err.Number & ": " & Err.Description
End Function

Private Function GetPosValue(ByVal sCadena As String, ByVal sClave As String, ByVal sCarFin) As Integer
On Error GoTo error
    GetPosValue = InStr(1, UCase(sCadena), sClave, vbTextCompare)
    GetPosValue = InStr(GetPosValue, UCase(sCadena), sCarFin, vbTextCompare)

Exit Function
error:
    GetPosValue = 0
End Function

Private Function GetValue(ByVal sCadena As String, ByVal PosIni As Integer, ByVal PosFin As Integer) As String
On Error GoTo error
    If PosFin = 0 And PosIni > 0 Then
        PosFin = Len(sCadena) - PosIni
        GetValue = Trim(Mid(sCadena, PosIni + 1, PosIni - PosFin - 1))
    ElseIf PosIni > 0 Then
        GetValue = Trim(Mid(sCadena, PosIni + 1, PosFin - PosIni - 1))
    Else
        GetValue = ""
    End If
Exit Function
error:
    GetValue = ""
    Debug.Print Err.Number & ": " & Err.Description
End Function

VBA Access. Obtener el número de posiciones decimales de un número.

Public Function NumeroDecimales(ByVal dNumber As Double) As Long
On Error GoTo error
    Dim Value As String
    Dim PosSymb As String
    Dim DecSymb As String
    Dim NumDecs As Long
   
    DecSymb = Mid(1 / 2, 2, 1)
   
    Value = CStr(dNumber)
    PosSymb = InStr(Value, DecSymb)
    If CLng(PosSymb) > 0 Then
        NumDecs = Len(Value) - CLng(PosSymb)
    Else
        NumDecs = 0
    End If
   
    NumeroDecimales = NumDecs
   
Exit Function
error:
    NumeroDecimales = 0
    MsgBox Err.number & ": " & Err.Description
End Function