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

VBA Access. Posicionar cursor en un registro concreto de un formulario con datos DAO.Recordset

Private Sub GotoRecord(ByVal strCriteria As String)
'Ejemplo stCriteria: [PKey] = 'ABCD'
On Error GoTo error
    Dim rs As DAO.Recordset
    Set rs = Me.SubForm.Form.RecordsetClone
    rs.FindFirst strCriteria
    If rs.NoMatch Then
        'Ningún valor encontrado
    Else
        Me.Subform.Form.Bookmark = rs.Bookmark
    End If

    rs.Close

    Set rs = Nothing

Exit Sub
error:
    MsgBox Err.Description
End Sub

VBA Access. Posicionar cursor en un registro concreto de un formulario con datos ADODB.Recordset

Private Sub GotoRecord(ByVal strCriteria As String)
'Ejemplo stCriteria: [PKey] = 'ABCD'

On Error GoTo error

    Dim rs As ADODB.Recordset
    Set rs = Me.SubForm.Form.RecordsetClone
    rs.Filter = strCriteria
    If Not rs.EOF Then
        Me.SubForm.Form.Bookmark = rs.Bookmark
    End If
    rs.Close
    Set rs = Nothing

Exit Sub
error:
    MsgBox Err.Description
End Sub

VBA Access. Finalizar la edición de un registro que se está modificando en un formulario.

    'Finaliza edicion registro
    If Me.Dirty Then
      Me.Dirty = False
    End If

VBA Access. Función NullIf.

'En Access no existe tal función.
'Nos puede ser útil en ciertas ocasiones combinándola con la función Nz.
'Ejemplo de uso: Nz(Nullif(Valor,""),"prueba")

Public Function NullIf(value As Variant, NullValue As Variant) As Variant
    If value = NullValue Then
        NullIf = Null
    Else
        NullIf = value
    End If
End Function

VBA Access. Módulo CursorPos. Obtener la posición del cursor X,Y.

Option Compare Database
Option Explicit

'http://www.utteraccess.com/forum/index.php?showtopic=1723895

'Windows API Function Declarations
#If Win64 = 1 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongLong
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Public Type POINTAPI
    X As Long
    Y As Long
End Type

#If Win64 = 1 Then
    Public Function GetCursorPosX() As LongLong
        Dim n As POINTAPI
        GetCursorPos n
        GetCursorPosX = n.X
    End Function
#Else
    Public Function GetCursorPosX() As Long
        Dim n As POINTAPI
        GetCursorPos n
        GetCursorPosX = n.X
    End Function
#End If

#If Win64 = 1 Then
    Public Function GetCursorPosY() As LongLong
        Dim n As POINTAPI
        GetCursorPos n
        GetCursorPosY = n.Y
    End Function
#Else
    Public Function GetCursorPosY() As Long
        Dim n As POINTAPI
        GetCursorPos n
        GetCursorPosY = n.Y
    End Function
#End If

VBA Access. Desactivar evento clic del botón derecho que abre el menú contextual en un formulario.

Forms("NombreDelFormulario").ShortcutMenu = False

VBA Access. Función para exportar un recordset a Excel.

Public Sub Export2Excel(ByRef rs As Variant, Optional ByVal bShowColumnNames As Boolean = True)
On Error GoTo error
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlWs As Object

    Dim recArray As Variant

    Dim strDB As String
    Dim fldCount As Integer
    Dim recCount As Long
    Dim iCol As Integer
    Dim iRow As Integer

    ' Create an instance of Excel and add a workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Hoja1")

    ' Copy field names to the first row of the worksheet
    If bShowColumnNames Then
        fldCount = rs.Fields.Count
        For iCol = 1 To fldCount
            xlWs.Cells(1, iCol).value = rs.Fields(iCol - 1).Name
        Next
    End If
   
    ' Check version of Excel
    If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
        'EXCEL 2000,2002,2003, or 2007: Use CopyFromRecordset
     
        ' Copy the recordset to the worksheet, starting in cell A2
        xlWs.Cells(IIf(bShowColumnNames, 2, 1), 1).CopyFromRecordset rs
        'Note: CopyFromRecordset will fail if the recordset
        'contains an OLE object field or array data such
        'as hierarchical recordsets
    Else
        MsgBox "Versión instalada de excel no soportada!", vbCritical
        Exit Sub
    End If

    ' Auto-fit the column widths and row heights
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit

    ' Display Excel and give user control of Excel's lifetime
    xlApp.Visible = True
    xlApp.UserControl = True

    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
       
Exit Sub
Resume
error:
    MsgBox Err.Description
End Sub