Obtener solo imágenes y convertir ruta en hiper vinculo
Siguiendo indicación formulo pregunta nueva en el tema excel:
Sobre la macro que amablemente me ayudo hace unos días, necesito obtener solo las imágenes (la ruta completa de archivo no de carpeta) y siendo que para su obtención se recorre un bucle seria muy útil para mi que el nombre completo del fichero, se convirtiera en un hiper link a la propia imagen.
Dim rutas As New Collection
'
Sub Listar_Archivos()
'Por.Dante Amor
'Listar archivos de carpeta y subcarpetas con sus propiedades
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ruta = "C:\trabajo"
ext = "*"
ActiveSheet.Rows("2:" & Rows.Count).Clear
Dim arrHeaders(34)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(ruta)
For i = 0 To 33
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
Cells(1, i + 1).Value = arrHeaders(i)
Next
'
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
carpeta = .SelectedItems(1)
End With
'
If carpeta = "" Then Exit Sub
'
pPath = carpeta & "\"
rutas.Add carpeta
Call agregadir(pPath)
'
For Each sd In rutas
Call Propiedades(sd)
Next
'
Set rutas = Nothing
Application.ScreenUpdating = True
MsgBox "Fin, listar archivos", vbInformation, "ARCHIVOS"
End Sub
'
Sub agregadir(lpath) 'Agrega directorios
'Por.Dante Amor
Dim subdir As New Collection
If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
DirFile = Dir(lpath & "*", vbDirectory)
Do While DirFile <> "" 'Agrega subdirectorios a collection
If DirFile <> "." And DirFile <> ".." Then _
If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
subdir.Add lpath & DirFile
DirFile = Dir
Loop
For Each sd In subdir
rutas.Add sd
Call agregadir(sd)
Next
End Sub
'
Sub Propiedades(subdir)
'Act Por Dante Amor
'
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(subdir)
fila = Range("A" & Rows.Count).End(xlUp).Row + 1
For Each strFileName In objFolder.Items
For i = 0 To 33
'Debug.Print i & vbTab & arrHeaders(i) & ": " & objFolder.GetDetailsOf(strFileName, i)
Cells(fila, i + 1).Value = objFolder.GetDetailsOf(strFileName, i)
Cells(fila, 35).Value = subdir
Next
fila = fila + 1
Next
End SubDespués de eso y tras convertir la columna de las etiquetas (F) a texto mediante el separador (;) punto y coma. Usaré un filtro avanzado más o menos así:
Sub Texto_a_Columnas()
Range("F").Select
Selection.TextToColumns Destination:=Range("F"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
True
End Sub
Sub Filtro_criterios()
Application.CutCopyMode = False
Range("S5:X159").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"S2:X3"), CopyToRange:=Range("Y6"), Unique:=False
End Sub
De forma aislada me funciona lo que le pido es adaptarlo a su macro, que es lo dificil
1 respuesta
Paso a paso.
Te respondo en esta pregunta lo de poner solamente archivos de imagen y el hyperlink del archivo para abrir la imagen.
Dbes colocar en esta línea de la macro, las extensiones que quieres seleccionar:
Case "jpg", "jpeg", "gif"
La macro que habías puesto no contempla la extensión en el archivo, por lo que tuve que hacer algunos cambios para obtener la extensión y de esa forma poder filtrar solamente las imágenes.
Dim rutas As New Collection
'
Sub Listar_Archivos()
'Por.Dante Amor
'Listar archivos de carpeta y subcarpetas con sus propiedades
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ruta = "C:\trabajo"
ext = "*"
ActiveSheet.Rows("2:" & Rows.Count).Clear
Dim arrHeaders(34)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(ruta)
For i = 0 To 33
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
Cells(1, i + 1).Value = arrHeaders(i)
Next
'
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
carpeta = .SelectedItems(1)
End With
'
If carpeta = "" Then Exit Sub
'
pPath = carpeta & "\"
rutas.Add carpeta
Call agregadir(pPath)
'
For Each sd In rutas
Call Propiedades(sd)
Next
'
Set rutas = Nothing
Application.ScreenUpdating = True
MsgBox "Fin, listar archivos", vbInformation, "ARCHIVOS"
End Sub
'
Sub agregadir(lpath) 'Agrega directorios
'Por.Dante Amor
Dim subdir As New Collection
If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
DirFile = Dir(lpath & "*", vbDirectory)
Do While DirFile <> "" 'Agrega subdirectorios a collection
If DirFile <> "." And DirFile <> ".." Then _
If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
subdir.Add lpath & DirFile
DirFile = Dir
Loop
For Each sd In subdir
rutas.Add sd
Call agregadir(sd)
Next
End Sub
'
Sub Propiedades(subdir)
'Act Por Dante Amor
'
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(subdir)
fila = Range("A" & Rows.Count).End(xlUp).Row + 1
archs = Dir(subdir & "\" & "*.*")
'For Each strFileName In objFolder.Items
Do While archs <> ""
wext = Mid(archs, InStrRev(archs, ".") + 1)
Select Case LCase(wext)
Case "jpg", "jpeg", "gif"
Set objFolderItem = objFolder.ParseName(archs)
For i = 0 To 33
'Debug.Print i & vbTab & arrHeaders(i) & ": " & objFolder.GetDetailsOf(strFileName, i)
'Cells(fila, i + 1).Value = objFolder.GetDetailsOf(strFileName, i)
Cells(fila, i + 1).Value = objFolder.GetDetailsOf(objFolderItem, i)
Cells(fila, 35).Value = wext
Cells(fila, 36).Value = subdir
Next
ActiveSheet.Hyperlinks.Add Anchor:=Cells(fila, "A"), _
Address:=subdir & "\" & archs
fila = fila + 1
End Select
archs = Dir()
Loop
'Next
End SubEn otra pregunta reviso lo de adaptar tu código.
'.[Sal u dos. Dante Amor. No olvides valorar la respuesta. '.[Avísame cualquier duda
