VBA Access. Listado de artículos con sus imágenes asociadas de una BdD Sql Server en un formulario con Botones e Imágenes (ejemplo de 4x4 botones/imágenes)

'Formulario de tipo único compuesto por:
'16 botones cmdBut1,cmdBut2, ... (Botón con estilo transparente para poder ver la imagen de detrás)
'16 imagenes (detrás de cada botón) Imagen1,Imagen2, ...
'16 textbox Desc1, Desc2,... (DEBAJO DE CADA BOTÓN/IMAGEN) cada uno de ellos con Origen de control = Desc1, Desc2, ... respectivamente
'16 textbox RefArt1,RefArt2,... (OCULTOS) cada uno de ellos con Origen de control = RefArt1, RefArt2, ... respectivamente
'16 textbox CodImg1,CodImg2,... (OCULTOS) cada uno de ellos con Origen de control = CodImg1, CodImg2, ... respectivamente
'4 botones para navegar por los registros (Anterior, Siguiente, Primero y Último)

Option Compare Database
Option Explicit

Const NUMBUTTONS = 16

Private Sub ProcessButtonClicked()
On Error GoTo error
    Dim NumButton As Integer
    NumButton = CInt(Replace(Me.ActiveControl.Name, "cmdBut", "0"))
    If Nz(Me.Controls("RefArt" & NumButton).Value, "") = "" Then Err.Raise 99, "ProcessButtonClicked", "Botón / RefArt N. " & NumButton & " sin definir!"
   
    MsgBox Me.Controls("RefArt" & NumButton).Value & " " & Me.Controls("Desc" & NumButton).Value, , ""

Exit Sub
error:
    MsgBox Err.Description, vbCritical, ""
End Sub

Private Sub cmdBut1_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut2_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut3_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut4_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut5_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut6_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut7_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut8_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut9_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut10_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut11_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut12_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut13_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut14_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut15_Click()
    ProcessButtonClicked
End Sub

Private Sub cmdBut16_Click()
    ProcessButtonClicked
End Sub

Private Sub LoadArticulos()
On Error GoTo error
    'Creamos recordset dinámico
    Dim rsD As New ADODB.Recordset
    With rsD
        Dim i As Integer
        For i = 1 To NUMBUTTONS
            .Fields.Append "RefArt" & i, adVarChar, 255, adFldKeyColumn
            .Fields.Append "Desc" & i, adVarChar, 255, adFldMayBeNull
            .Fields.Append "CodImg" & i, adInteger, , adFldMayBeNull
        Next i
       
        .CursorType = adOpenKeyset
        .CursorLocation = adUseClient
        .LockType = adLockPessimistic
        .Open
    End With
   
    'A partir del recordset original, creamos otro recordset dinámicamente para simular un total de NUMBUTTONS por cada fila/pantalla
    Dim rsArt As New ADODB.Recordset
    Dim cnArt As New ADODB.Connection
    cnArt.ConnectionString = DimeCadenaConexion
    cnArt.Open
    rsArt.Open "SELECT TOP 1000 UPPER(ReferenciaArtículo) AS ReferenciaArtículo,UPPER(Descripción) AS Descripción,CodigoImagen FROM Artículos", _
                cnArt, adOpenStatic, adLockReadOnly
   
    'Rellenamos el recordset dinámico que al final asignaremos al formulario
    Do Until rsArt.EOF
        rsD.AddNew
   
        Dim j As Integer
        For j = 1 To NUMBUTTONS
            If Not rsArt.EOF Then
                rsD("RefArt" & j) = rsArt!ReferenciaArtículo
                rsD("Desc" & j) = rsArt!DESCRIPCIÓN
                rsD("CodImg" & j) = Nz(rsArt!CodigoImagen, 0)
                rsArt.MoveNext
            End If
        Next j
       
        rsD.Update
    Loop
    Set Me.Recordset = rsD
   
    rsArt.Close
    cnArt.Close
    Set rsArt = Nothing
   
    rsD.Close
    Set rsD = Nothing
   
    DoCmd.GoToRecord , , acFirst

Exit Sub
Resume
error:
    MsgBox Err.Number & ": " & Err.Description
End Sub

Private Sub cmdRegAnterior_Click()
On Error Resume Next
    DoCmd.GoToRecord , , acPrevious
End Sub

Private Sub cmdRegPrimero_Click()
On Error Resume Next
    DoCmd.GoToRecord , , acFirst
End Sub

Private Sub cmdRegSiguiente_Click()
On Error Resume Next
    DoCmd.GoToRecord , , acNext
End Sub

Private Sub cmdRegUltimo_Click()
On Error Resume Next
    DoCmd.GoToRecord , , acLast
End Sub

Private Sub Form_Current()
On Error Resume Next
    CargarImagenes
End Sub

Private Sub CargarImagenes()
On Error GoTo error
    'Asignaremos al registro actual / pantalla, las 16 imágenes que tienen asignadas por código de imagen
    '1 Consultaremos en la BdD la imagen y si esta no existe en la carpeta "Images" , con el mismo nombre de la referencia
    '2 Asignamos a cada control Imagen, el path de la imagen que deben cargar. Ej. Imagen1.Picture = "C:\...\Images\ficheroimagen"

    Debug.Print "Cargando Imágenes " & Now
   
    'Application.Echo False

    Dim fso As New FileSystemObject
    If Not fso.FolderExists(CurrentProject.Path & "\Images") Then fso.CreateFolder (CurrentProject.Path & "\Images")

    Dim i As Integer
    For i = 1 To NUMBUTTONS
        Dim CodigoImagen As Long
        CodigoImagen = Nz(Me.Controls("CodImg" & i), 0)
        If CodigoImagen <> 0 Then
            Dim rs As New ADODB.Recordset
            Dim cn As New ADODB.Connection
           
            cn.Open DimeCadenaConexion
            rs.Open "SELECT * FROM Imagenes WHERE CodigoImagen = " & CodigoImagen, cn, adOpenStatic, adLockReadOnly
            If Not rs.EOF Then
                Dim sFName  As String
                If Nz(rs!Fichero, "") <> "" Then
                    sFName = CurrentProject.Path & "\Images\" & Me.Controls("RefArt" & i) & "." & fso.GetExtensionName(rs!Fichero)
                   
                    If Not fso.FileExists(sFName) Then
                        Dim objStream As New ADODB.Stream
                        objStream.Type = adTypeBinary
                        objStream.Open
                        objStream.Write rs!Imagen
                        objStream.SaveToFile sFName, adSaveCreateOverWrite
                        objStream.Close
                        Set objStream = Nothing
                    End If
               
                    If fso.FileExists(sFName) Then
                        Me.Controls("Imagen" & i).Picture = sFName
                    Else
                        Me.Controls("Imagen" & i).Picture = ""
                    End If
                End If
            Else
                Me.Controls("Imagen" & i).Picture = ""
            End If
           
            rs.Close
            cn.Close
            Set rs = Nothing
           
        Else
            Me.Controls("Imagen" & i).Picture = ""
        End If
    Next i
   
    Set fso = Nothing
   
    'Application.Echo True
   
Exit Sub
error:
    MsgBox Err.Number & ": " & Err.Description
End Sub

Private Sub Form_Load()
    LoadArticulos
End Sub