Macro para mostrar Imágenes jpg O jpeg
Recurro a su conocimiento porque no se como resolver este problema. La cuestión es que tengo las imágenes en un directorio y algunas con jpg y otras jpeg, por lo cual debería buscar por una extensión y si no lo encuentra con esa, buscar con la otra. No se como escribir para darme cuenta que si no lo encontró lo busque con la otra extensión. ¿Me podrán ayudar? Muchas Gracias! Oscar.
La rutina que uso:
Sub busca_imagen_3000()
Application.ScreenUpdating = False
Dim codigo As String
Dim cod2 As String
Dim Pic As Shape
ActiveSheet.Pictures.Select
Selection.Delete
Range("B2").Select
codigo = Left(Cells(ActiveCell.Row, 1), 6) & "_" & Right(Cells(ActiveCell.Row, 1), 2)
While Cells(ActiveCell.Row, 1) <> Empty
ActiveCell.RowHeight = 45 '105
ActiveCell.ColumnWidth = 9 '24
ruta = "\\buefs01\common files\FotosSKU\" ' carpeta adicional con las fotos, fuera de la red
On Error GoTo NoEncontrado:
ActiveSheet.Pictures.Insert(ruta & codigo & ".jpg").Select
On Error GoTo NoEncontrado:
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Top = ActiveCell.Top + 5
.Left = ActiveCell.Left + 5
.ShapeRange.Height = ActiveCell.Height - 10
.ShapeRange.Width = ActiveCell.Width - 10
End With
NoEncontrado:
Resume 1
1:
codigo = Left(Cells(ActiveCell.Row + 1, 1), 6) & "_" & Right(Cells(ActiveCell.Row + 1, 1), 2)
Cells(ActiveCell.Row + 1, 2).Select
Wend
ActiveSheet.Pictures.Select
On Error GoTo Nohayfoto:
With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With
Nohayfoto:
Resume 2
2:
Application.ScreenUpdating = True
End Sub
1 respuesta
Con la función Dir( ) puedes verificar si existe el archivo.
En la columna "C" te estoy poniendo un mensaje si no existe el archivo, si no quieres el mensaje puedes quitar esta línea de la macro:
Cells(i, "C") = "Archivo no existe ni como jpg ni como jpeg"
El código actualizado:
Sub busca_imagen_3000()
'Act.Por.Dante Amor
Application.ScreenUpdating = False
ActiveSheet.Pictures.Delete
ruta = "\\buefs01\common files\FotosSKU\" ' carpeta adicional con las fotos, fuera de la red
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Cells(i, "A").RowHeight = 45 '105
Cells(i, "A").ColumnWidth = 9 '24
codigo = Left(Cells(i, 1), 6) & "_" & Right(Cells(i, 1), 2)
ext = ".jpg"
If Dir(ruta & codigo & ext) = "" Then
ext = ".jpeg"
If Dir(ruta & codigo & ext) = "" Then
ext = ""
End If
End If
If ext <> "" Then
With ActiveSheet.Pictures.Insert(ruta & codigo & ext)
.ShapeRange.LockAspectRatio = msoFalse
.Top = Cells(i, "B").Top + 5
.Left = Cells(i, "B").Left + 5
.ShapeRange.Height = Cells(i, "B").Height - 10
.ShapeRange.Width = Cells(i, "B").Width - 10
.Placement = xlMoveAndSize
.PrintObject = True
End With
Else
Cells(i, "C") = "Archivo no existe ni como jpg ni como jpeg"
End If
Next
Application.ScreenUpdating = True
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
