Estuve mucho tiempo fuera en otras cosas y recién pude ingresar al foro. Claro que te puedo ayudar... Aqui te dejo el modulo y el registro en el formulario para que puedas ajustarlo a tu necesidad.
En el formulario
Option Compare Database
Private Sub Comando22_Click()
Dim misImagenes As String
Dim n As Integer
Dim laImagen As String
Dim fso As Scripting.FileSystemObject
Dim destino As String
Const carpetaFotos As String = "\Tools\Imagenes\"
misImagenes = fncBuscaImagenes
'Como yo tengo 5 controles de imagen, y la matriz empieza en 0, hay que trabajar con 4, es decir,
'con un número menos que controles imagen tengas (si tienes 10, trabajas con 9)
n = IIf(UBound(Split(misImagenes, "|")) < 4, UBound(Split(misImagenes, "|")), 4)
'Compruebas que existe la carpeta, si no la creas (hay que crear carpeta a carpeta)
If Dir(Application.CurrentProject.Path & carpetaFotos, vbDirectory) = "" Then
MkDir Application.CurrentProject.Path & "\Tools"
MkDir Application.CurrentProject.Path & carpetaFotos
End If
For i = 0 To n
Set fso = CreateObject("Scripting.FileSystemObject")
laImagen = Split(misImagenes, "|")(i)
destino = Application.CurrentProject.Path & carpetaFotos & Me.Campo1 & Format(i + 1, "000") & "." & Right(laImagen, Len(laImagen) - InStrRev(laImagen, "."))
fso.MoveFile laImagen, destino
Me.Controls("Foto" & i + 1) = Me.Campo1 & Format(i + 1, "000") & "." & Right(laImagen, Len(laImagen) - InStrRev(laImagen, "."))
Me.Controls("Imagen" & i + 1).Picture = Application.CurrentProject.Path & carpetaFotos & Me.Controls("Foto" & i + 1)
Next i
Exit Sub
For i = n + 1 To 4
Me.Controls("Foto" & i + 1) = ""
Me.Controls("Imagen" & i + 1).Picture = ""
Next i
Salida:
Exit Sub
End Sub
Modulo
Option Compare Database
'------------------------------------------------------------------------------------------------
' Función para abrir ventana de diálogo y buscar imagenes para las Hembras y Machos
'------------------------------------------------------------------------------------------------
Public Function fncBuscaImagenes() As String
On Error GoTo Sol_err
Dim fDialog As Office.FileDialog
Dim vrtSelectedItem As Variant
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = True 'Esto tiene que ir en True para poder seleccionar varios archivos
.ButtonName = "Seleccionar"
.Title = "Seleccionar el archivo"
.InitialFileName = Application.CurrentProject.Path & "\"
.InitialView = msoFileDialogViewDetails
.Filters.Clear
.Filters.Add "Imágenes", "*.jpg; *.jpeg; *.bmp ; *.gif"
If .Show = True Then
For Each vrtSelectedItem In .SelectedItems 'Tienes que recorrer la colección de elementos seleccionados
fncBuscaImagen = fncBuscaImagen & vrtSelectedItem & "|"
Next
fncBuscaImagenes = Left(fncBuscaImagen, Len(fncBuscaImagen) - 1)
Else
'No hacemos nada
End If
End With
Salida:
Exit Function
Sol_err:
MsgBox "Se ha producido el error: " & Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "ERROR"
Resume Salida
End Function
Fue de gran ayuda por parte de Sveinbjorn.