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

VBA Access. Módulo de clase clsTimer. Crear uno o varios Timer independiente(s) sin depender del formulario. (2/2)

Option Compare Database
Option Explicit

'1 Crearemos el timer o timers que necesitemos instanciando esta clase sin depender del formulario.
'Ej: Public WithEvents oTimer1 As clsTimer

'2 Para definir las acciones a realizar en el evento OnTimer, en el formulario, debemos crear un 'procedimento que se llamará: Nombre del objeto timer que hallamos creado  + "_OnTimer". 

'Ejemplo objeto oTimer1 -> Private Sub oTimer1_OnTimer() ..... End Sub
'3 Iniciar timer: oTimer1.Startit
'4 Parar timer: oTimer1.Stopit

'https://access-programmers.co.uk/forums/showthread.php?t=232012

Option Compare Database

Option Explicit

'Windows API Function Declarations

#If Win64 = 1 Then

    Private Declare PtrSafe Function SetTimer Lib "user32" ( _

        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _

        ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongLong

    

    Private Declare PtrSafe Function KillTimer Lib "user32" ( _

        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongLong

#Else

    Private Declare Function SetTimer Lib "user32" ( _

        ByVal hWnd As Long, ByVal nIDEvent As Long, _

        ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

    

    Private Declare Function KillTimer Lib "user32" ( _

        ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

#End If

#If Win64 = 1 Then

    Private TimerID As LongLong

#Else

    Private TimerID As Long

#End If

Public Event OnTimer()

'Start timer

Public Sub Startit(IntervalMs As Long)

    TimerID = SetTimer(Application.hWndAccessApp, ObjPtr(Me), IntervalMs, AddressOf Timers.TimerProc)

End Sub

'Stop timer

Public Sub Stopit()

    If TimerID <> -1 Then

        KillTimer Application.hWndAccessApp, TimerID

        TimerID = 0

    End If

End Sub

'Trigger Public event

Public Sub RaiseTimerEvent()

    RaiseEvent OnTimer

End Sub

VBA Access. Módulo Timers. Crear uno o varios Timer independiente(s) sin depender del formulario. (1/2)

'Crear un módulo llamado Timers

'https://access-programmers.co.uk/forums/showthread.php?t=232012

#If Win64 = 1 Then

    Public Sub TimerProc(ByVal hwnd As LongPtr, _

                             ByVal uMsg As LongLong, _

                             ByVal oTimer As clsTimer, _

                             ByVal dwTime As LongLong)

       ' Alert appropriate timer object instance.

       If Not oTimer Is Nothing Then

            oTimer.RaiseTimerEvent

            Debug.Print "evento timer"

       End If

    End Sub

#Else

    Public Sub TimerProc(ByVal hwnd As Long, _

                         ByVal uMsg As Long, _

                         ByVal oTimer As clsTimer, _

                         ByVal dwTime As Long)

       ' Alert appropriate timer object instance.

       If Not oTimer Is Nothing Then

            oTimer.RaiseTimerEvent

            Debug.Print "evento timer"

       End If

    End Sub

#End If

VBA Access. Módulo de Clase clsCarousel. Clase para hacer un carrusel de imágenes combinándola con un timer.

Option Compare Database
Option Explicit

'1 En el formulario donde haremos el carrusel, definimos una variable del tipo clsCarousel
'2 Crearemos un control imagen
'3 Instanciamos el objeto y llamamos al método LoadImages pasando la carpeta donde contenga las imágenes y el nombre del control imagen por referencia
'4 Iniciamos un Timer con el refresco que queramos
'5 cada evento del timer (OnTimer), llamaremos al método NextImage

Private ControlImagen As Control
Private NumImagenActual As Integer
Private DiccionarioImagenes As Dictionary

Private Sub Class_Initialize()
    NumImagenActual = 0
End Sub

Private Sub Class_Terminate()
    If Not DiccionarioImagenes Is Nothing Then
        DiccionarioImagenes.RemoveAll
        Set DiccionarioImagenes = Nothing
    End If
End Sub

Function LoadImages(ByVal CarpetaImagenes As String, ByRef ctlImagen As Control) As Boolean
On Error GoTo error
    Set DiccionarioImagenes = New Dictionary
 
    Dim i As Integer
    i = 0
    Dim file As Object
    Dim fso As New FileSystemObject
    For Each file In fso.GetFolder(CarpetaImagenes).Files
        i = i + 1
        DiccionarioImagenes.Add CStr(i), CStr(file)
    Next file
     
    Set ControlImagen = ctlImagen
    NextImage
 
    LoadImages = True
Exit Function
Resume
error:
    LoadImages = False
    Debug.Print Err.Number & ": " & Err.Description
End Function

Function NextImage()
On Error Resume Next
    NumImagenActual = NumImagenActual Mod DiccionarioImagenes.Count + 1
    ControlImagen.Picture = DiccionarioImagenes.Item(CStr(NumImagenActual))
End Function

VBA Access. Modulo ModTransparent. Permite hacer un formulario totalmente visible, translúcido o transparente del todo.

Option Compare Database
Option Explicit

'http://grupos.emagister.com/debate/formulario_transparente/6411-674789
'
'Uso por ejemplo en el load del formulario: Transparent Me, 100
'
'Los valores posibles son entre 0 totalmente transparente y 255 totalmente visible.
'Para que funcione debes poner este código en un módulo nuevo

#If Win64 = 1 Then
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
#Else
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
#End If

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2

Function Transparent(frm As Form, Nivel As Integer)
    Dim lngHwnd As Long
    If Nivel < 0 Or Nivel > 255 Then Exit Function
    lngHwnd = frm.hWnd
    SetWindowLong lngHwnd, GWL_EXSTYLE, GetWindowLong(lngHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetLayeredWindowAttributes lngHwnd, 0, Nivel, LWA_ALPHA
End Function