crear hipervinculos de archivos

[mariomenc]

hola,

me gustaria saber si alguien puede ayudar se trata de lo siguiente, tengo un disco con muchos archivos de todo tipo (dibujos de ingenieria) y cada vez que quiero encontrar alguno de ellos tengo que ir al motor de busqueda del explorador de windows y normalmente tarda un tiempo en encontrarlo, me gustaria saber si se puede crear un indice de archivos con sus subcarpetas y que estos cree un hipervinculo para abrirlo desde excel.

les agradezo de antemano su atencion, gracias.

 

[Greg Truby]

Claro que sí, se puede. ¿Puede usted mostrarnos el código de VBA que ha escrito usted hasta el momento?

 

[mariomenc]

hasta este momento solo eh podido crear el listado de los archivos pero no sé como convertirlos en hipervinculos.

Sub IndiceArchivos()
    
Sheets.Add
ActiveSheet.Name = "Indice"

With Application.FileSearch
    ' Change as applicable.
    .LookIn = "D:\QASYSTEM"
    .FileType = msoFileTypeAllFiles
    .SearchSubFolders = True
    .Execute
End With
    
cnt = Application.FileSearch.FoundFiles.Count

For i = 1 To cnt
    rng = "A" & i
    Range(rng).Value = Application.FileSearch.FoundFiles.Item(i)
Next

End Sub

agradezco su atencion, gracias.

 

[ST2]

prueba cambiando........

For i = 1 To cnt
    With ActiveSheet
    .Hyperlinks.Add .Range("A" & i), Application.FileSearch.FoundFiles.Item(i)
    End With
Next

 

[galileogali]

Que tal todos!
Termino de probar el codigo.
Bien en Excel 2003.

en el 2007, parece que FILESEARCH ha dejado de funcionar....
No reconoce como válido
Application.Filesearch
un bug o algo anunciado?

GALILEOGALI

 

[ST2]

que tal Gali,practicamente me adivinaste el pensamiento,pues efectivamente en la version 2007 genera el error 445.-el objeto no admite esta acción.(Hizo referencia a un método o propiedad que no son compatibles con este objeto)

segun leo/entiendo el problema es que la propiedad *filesearch* del objeto application esta oculta(ver...Cambios realizados en el modelo de objetos desde Microsoft Office 2003,en la ayuda 2007 ),el asunto es si alguien sabe alguna manera/metodo para 'descultar' y usar para despues regresar a su estado natural en la version 2007?

la verdad es que andamos perdidos.....

if St and Gali = "perdidos" then msgbox "Hay alguien que ayude"

 

[Greg Truby]

Hola caballeros,

Disculpe la demora en responder. Hace tiempos hice un programa que me da un listado de programas con sus tamaños. Como base usé código que agarré de Juan Pablo. Usa el FileSystemObject. En el caso mio hago referencia a la biblioteca de SCRIPTING. Si uno quiere hacerlo con late binding vea el código original de Juan Pablo.

Para la situación suya donde quiere vínculos tuve que commentar unas líneas. Creo que esto le serviría.

Option Explicit

Private fsoSystem As FileSystemObject

'____________________
Sub ListFolderSizes()
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
' Based on code posted by JPG here:
' http://www.mrexcel.com/board2/viewtopic.php?t=51719
    
    Dim strStartPath As String, strToAbbr As String
    Dim varFileInfo() As Variant
    Dim booSubFolders As Boolean, booListFiles As Boolean
    Dim rngCurrent As Range, rngCell As Range, rngCol As Range
    Dim p%
    
    Set fsoSystem = New FileSystemObject
    
    strStartPath = GetStartPath
    booSubFolders = (vbYes = MsgBox("Search subfolders?", vbYesNo + vbQuestion))
    booListFiles = (vbYes = MsgBox("List files?", vbYesNo + vbQuestion + vbDefaultButton2))
    
    
    ReDim varFileInfo(1 To 2, 1 To 1)
    varFileInfo(1, 1) = "Folder Name"
    varFileInfo(2, 1) = "Folder Size"
    GetFolderInfo varFileInfo, strStartPath, booSubFolders, booListFiles
    Set fsoSystem = Nothing
    Range("A1").Resize(UBound(varFileInfo, 2), 2).Value = Application.Transpose(varFileInfo)
    Application.StatusBar = False
    If Not booSubFolders Then Exit Sub
    Set rngCurrent = [a1].CurrentRegion
    rngCurrent.Font.Name = "Courier New"
    rngCurrent.Sort Key1:=Range("A1"), Header:=xlYes
    rngCurrent.Columns(3).FormulaR1C1 = "=(LEN(RC[-2]) - LEN(SUBSTITUTE(RC[-2],""\"","""")))"
    [C1].FormulaR1C1 = "=MAX(R[1]C:R[" & rngCurrent.Rows.Count - 1 & "]C)"
    rngCurrent.Columns(2).NumberFormat = _
        "[Black][>1000000]#,###.0,,"" MB"";[Blue][>1000]#.0,"" KB"";[Magenta]0 "" B"""
'    If [C2] > 1 Then
'        Set rngCol = rngCurrent.Columns(1)
'        Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
'        strToAbbr = Mid(strStartPath, 1, InStrRev(Left(strStartPath, Len(strStartPath) - 1), _
'                    Application.PathSeparator))
'        rngCol.Replace what:=strToAbbr, _
'                       Replacement:=Left(strToAbbr, 2) & "..\", _
'                       LookAt:=xlPart
'    End If
    With rngCurrent.Columns(3)
        .Formula = .Value
    End With
    Set rngCol = rngCurrent.Columns(1)
    Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
    '// Anything that's missing a period (no file extension)
    '// is assumed to be a folder (not 100% accurate, but close)
    If booListFiles Then
        With rngCol.FormatConditions
            .Delete
            .Add Type:=xlExpression, _
                 Formula1:="=ISERROR(SEARCH(""."",A1))"
            With .Item(1).Font
                .Bold = True
                .Italic = False
                .ColorIndex = 5     'blue
            End With
        End With
    End If
'    Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
'    For Each rngCell In rngCol.Cells
'        With rngCell
'            p = InStrRev(.Value, Application.PathSeparator)
'            .Value = Space(p - 1) & Right(.Text, Len(.Text) - p + 1)
'            .Offset(, 1).Cut .Offset(, .Offset(, 2))
'            If .Offset(, 2).NumberFormat = "General" Then .Offset(, 2).Clear
'        End With
'    Next rngCell
    [C1:C2].Clear
    
End Sub

'__________________________________________________
Sub GetFolderInfo(ByRef varFileInfo As Variant, _
                  ByVal strFolder As String, _
                  ByVal booSubFolders As Boolean, _
                  ByVal booListFiles As Boolean)
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Dim fsoFolder As Scripting.Folder, fsoSubFolder As Scripting.Folder
    Dim fsoFile As Scripting.File
    Dim lngFolderCount As Long
    
    On Error GoTo err_GetFolderInfo
    Set fsoFolder = fsoSystem.GetFolder(strFolder)
    lngFolderCount = UBound(varFileInfo, 2) + 1
    ReDim Preserve varFileInfo(1 To 2, 1 To lngFolderCount)
    varFileInfo(1, lngFolderCount) = fsoFolder.path
    varFileInfo(2, lngFolderCount) = fsoFolder.Size
    On Error GoTo 0
    If booListFiles Then
        For Each fsoFile In fsoFolder.Files
            lngFolderCount = UBound(varFileInfo, 2) + 1
            Application.StatusBar = "Items Found: " & lngFolderCount
            ReDim Preserve varFileInfo(1 To 2, 1 To lngFolderCount)
            varFileInfo(1, lngFolderCount) = fsoFile.path
            varFileInfo(2, lngFolderCount) = fsoFile.Size
        Next fsoFile
    End If
        
    If booSubFolders Then
        On Error GoTo err_GetFolderInfo
        For Each fsoSubFolder In fsoFolder.SubFolders
            If Not fsoSubFolder Is Nothing Then
                GetFolderInfo varFileInfo, fsoSubFolder.path, True, booListFiles
            End If
        Next fsoSubFolder
    End If
    Set fsoFolder = Nothing
    Exit Sub

err_GetFolderInfo:
'¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨

    Select Case Err.Number
        Case 70         ' (permission denied)
            varFileInfo(2, lngFolderCount) = 1
            Resume Next
        Case Else
            MsgBox "Error # " & Err.Number & ": " & Err.Description
    End Select
End Sub

'________________________________________
Private Function GetStartPath() As String
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Dim strDir As String, strPS As String
    Dim fdDir As FileDialog
    
    strPS = Application.PathSeparator
    Set fdDir = Application.FileDialog(msoFileDialogFolderPicker)
    
    [a1].Select
    If ActiveCell = "" Then
        fdDir.InitialFileName = Application.DefaultFilePath & strPS
    Else
        fdDir.InitialFileName = [a1]
    End If
    
    With fdDir
        If .Show = 0 Then Exit Function
        strDir = .SelectedItems(1)
    End With
    
    GetStartPath = strDir & IIf(Right(strDir, 1) <> strPS, strPS, vbNullString)
        
End Function

En cuanto a hacer los hipervínculos, vas a reír... es tan fácil...en cualquier columna que quiere ponga la fórmula =hyperlink(celda con nombre completo del archivo,"vínculo") y ya tiene. También se puede convertir el listado en sí a hipervínculos, pero a mí no me gusta eso porque siempre hago un cliq por accidente y ¡zas! ya voy al bendito lugar sin querer. Entonces prefiero poner los vínculo por aparte.

 

[ST2]

gracias Greg,aunque la duda era con respecto a *filesearch*
pues entendemos que existen algunas variantes paralelas para obtener la lista con links como esta otra ,que tiene la incomodidad de tener que seleccionar los archivos que se listaran en la hoja (por supuesto quien menos necesita de el ,pues eres tu ,pero lo pongo ,por nuestro compañero de foro que inicio la pregunta,ya que nunca dijo si usa 2003 0 2007)

Sub Lista_Archivos_ST()
    'Declare una variable como un objeto FileDialog.
    Dim fd As FileDialog

    'Cree un objeto FileDialog como un cudaro de dialogo.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Declare la variable que contendra la ruta de cada
    'elemento seleccionado. Even though the path is aString,
    'la variable debe ser un Variant por que la rutina (bucle  For Each...Next)
    'solo trabaja con Variants and Objects.
    Dim Elemento_Seleccionado As Variant

    'Use a With...End With block to reference the FileDialog object.
    With fd
        'Cambia el texto del boton.
        .ButtonName = "Incorporar"

        'Use el metodo Show para mostrar el cuadro de dialogo y regresar la accion del usuario.
        'si el usuario presiona el boton...
        If .Show = -1 Then
        i = 1
            'Step through eachString in the FileDialogSelectedItems collection.
            For Each Elemento_Seleccionado In .SelectedItems
                ActiveSheet.Hyperlinks.Add Range("A" & i), Elemento_Seleccionado
                i = i + 1
            Next Elemento_Seleccionado
        'si el usuario presiona Cancel...
        Else
        End If
    End With
    Set fd = Nothing

End Sub

la idea se me ocurrio al ver tu codigo y copie/pegue de la ayuda...
nuevemente vuelvo a notar que una linea de codigo no me funcionó en la version 2007 :-> (.ButtonName = "Incorporar")

que le vamos a hacer.....mientras,le veré el lado positivo al asunto

 

[Greg Truby]

Bueno, una idea interesante. No me había ocurrido.

En cuanto al Filesearch, ya estoy en casa donde no tengo ni el 1% de código que tengo en el trabajo. Pero lo que le puedo decir es que en la oficina también tengo una rutina hecho por Richard Schollar (otro MVP) que usa FileSearch y eso nunca me funcionó bien. Mientras usar el FSO nunca me ha fallado. Y yo uso XL2003. Entonces no recomendaría una solucion basada en el FileSearch.

 

[Juan Pablo González]

Además, Application.FileSearch ya no existe en Excel 2007... entonces mejor cambiar el código de una vez, no?