Problemas con Hipervínculos

hola, Luis !

... En cierta columna de una hoja... tengo Hipervínculos a ciertos archivos en cada celda.
... algunos de esos archivos han cambiado de ubicacion (No... de nombre) por lo cual los vinculos se rompieron.
... una macro se busque al abrir el libro aquellos archivos cuyo vinculo se rompio y
... automaticamente se creen los hipervinculos a la nueva ubicacion de los archivos...

1) si son muchos vinculos 'rotos' [y/o la primera vez que se corra el proceso]... va a ser 'tardadito'
2) el siguiente ejemplo esta preparado para buscar los archvos 'perdidos' SOLO en unidades 'locales'
si necesitas buscar en unidades 'desmontables/flash/...' te incluyo los codigos aplicables para cada tipo de unidad
3) requiere llamar API's de windows y la funcion vba InStrRev [disponibe solo a partir de vba6/excel 2000]
si la necesitas para excel 97... te incluyo una funcion preparada al final de un modulo 'estandar'

si cualquier duda [o informacion adicional]... comentas ?
saludos,
hector.

a) copia/pega lo siguiente en el modulo de codigo del libro [ThisWorkbook]

Private Sub Workbook_Open()
Dim Salto As Hyperlink, Archivo As String
With Worksheets("hoja1")
For Each Salto In .Hyperlinks
If Dir(Salto.Address) = "" Then
Archivo = Buscar_archivo( _
Mid(Salto.Address, InStrRev(Salto.Address, "\") + 1))
If Archivo <> "" Then
Salto.Address = Archivo
' .Range(Salto.Range.Address) = Archivo
Else
Salto.Delete
End If
End If
Next
End With
End Sub

2) copia lo siguiente en un modulo de codigo 'estandar/general/normal/...'

Option Private Module
Declare Function Busca_en_FAT Lib "ImageHlp.dll" Alias "SearchTreeForFile" _
(ByVal Unidad As String, ByVal Archivo As String, ByVal Reserva As String) As Long
Function Buscar_archivo(ByVal Archivo As String)
Dim Disco As Object, Unidad As String: Buscar_archivo = ""
With CreateObject("Scripting.FileSystemObject")
For Each Disco In .Drives
If Disco.DriveType = 2 Then
Unidad = Disco.DriveLetter & ":\": Buscar_archivo = Buscar(Unidad, Archivo)
If Buscar_archivo <> "" Then Exit For
End If: Next: End With
End Function
' Tipos para Disco.DriveType _
0 = "Desconocido" _
1 = "Desmontable" _
2 = "Fijo" _
3 = "Unidad de red" _
4 = "CD-ROM" _
5 = "Disco RAM"
Function Buscar(Unidad As String, Archivo As String) As String
Dim Pos As Long, Tmp As Long, Reserva As String: On Error GoTo No_existe
Reserva = Space(260): Tmp = Busca_en_FAT(Unidad, Archivo, Reserva)
Pos = InStr(Reserva, vbNullChar)
If Not Pos Then Reserva = Left(Reserva, Pos - 1)
Buscar = Reserva: Exit Function
No_existe:
End Function
#If Not VBA6 Then
Function InStrRev(ByVal Donde As String, ByVal Que As String) As Long
Dim Pos As Integer: InStrRev = 0: If Len(Que) <> 1 Then Exit Function
For Pos = Len(Donde) To 1 Step -1
If Mid(Donde, Pos, 1) = Que Then InStrRev = Pos: Exit Function
Next
End Function
#End If