I've just spent the best part of a day entering hyperlinks to files in a
shared drive - eg '\\servername\drive\filename.pdf'
After closing the worksheet and opening it up again, I now find that Excel
has amended all the links to '../../drive/filename.pdf' so that when I click
the link it thinks I'm looking for a website and comes up with the error
message - 'The address of the site is not valid. Check the address and try
again.'
I've tried changing one back but the same thing happened as soon as I closed
it and opened it again.
HELP!

Hope this can help. It is a macro module that lets you point to files and
automatically creates a worksheet with the file information and a link to
that file.
The main sub that you would call is named...
ListFilesToWorksheet()

HTH,
--
Gary Brown

If this post was helpful, please click the ''Yes'' button next to ''Was this
Post Helpfull to you?''.

'================================================= ==
'created using John Walkenbach's
' "Microsoft Excel 2000 Power
' Programming with VBA" example as a
' basic starting point
'================================================= ==
'32-bit API declarations
Private Declare Function SHGetPathFromIDList _
Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder _
Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

'================================================= ==
'Public Type BROWSEINFO
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'================================================= ==

Public Sub ListFilesToWorksheet()
On Error Resume Next
Dim blnSubFolders As Boolean
Dim dblLastRow As Long
Dim i As Integer, r As Integer, x As Integer
Dim y As Integer, iWorksheets As Integer
Dim Msg As String, Directory As String, strPath As String
Dim strResultsTableName As String, strFilename As String
Dim strWorksheetName As String
Dim strFileNameFilter As String, strDefaultMatch As String
Dim strExtension As String, strFileBoxDesc As String
Dim strMessage_Wait1 As String, strMessage_Wait2 As String
Dim varSubFolders As Variant, varAnswer As String

'/==========Variables=============
strResultsTableName = "File_Listing"
strDefaultMatch = "*.*"
r = 1
i = 1
blnSubFolders = False
strMessage_Wait1 = _
"Please wait while search is in progress..."
strMessage_Wait2 = _
"Please wait while formatting is completed..."
'/==========Variables=============

strFileNameFilter = _
InputBox("Ex: *.* with find all files" & vbCr & _
" blank will find all Office files" & vbCr & _
" *.xls will find all Excel files" & vbCr & _
" G*.doc will find all Word files beginning with G" _
& vbCr & _
" Test.txt will find only the files named TEST.TXT" _
& vbCr, _
"Enter file name to match:", Default:=strDefaultMatch)

If Len(strFileNameFilter) = 0 Then
varAnswer = _
MsgBox("Continue Search?", vbExclamation + vbYesNo, _
"Cancel or Continue...")
If varAnswer = vbNo Then
GoTo Exit_ListFiles
End If
End If

If Len(strFileNameFilter) = 0 Then
strFileBoxDesc = "All MSOffice files"
Else
strFileBoxDesc = strFileNameFilter
End If

Msg = "Look for: " & strFileBoxDesc & vbCrLf & _
" - Select location of files to be " & _
"listed or press Cancel."
Directory = GetDirectory(Msg)

If Directory = "" Then
Exit Sub
End If

If Right(Directory, 1) < Application.PathSeparator Then
Directory = Directory & Application.PathSeparator
End If

varSubFolders = _
MsgBox("Search Sub-Folders of " & Directory & " ?", _
vbInformation + vbYesNoCancel, "Search Sub-Folders?")

If varSubFolders = vbYes Then blnSubFolders = True
If varSubFolders = vbNo Then blnSubFolders = False
If varSubFolders = vbCancel Then Exit Sub

'check for an active workbook
' if no workbooks open, create one
If ActiveWorkbook Is Nothing Then
Workbooks.Add
End If

'save name of current worksheet
strWorksheetName = ActiveSheet.name

'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count

'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False 'turn warnings off
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True 'turn warnings on
Exit For
End If
Next

'Add new worksheet where results will be located
Worksheets.Add.Move after:=Worksheets(ActiveSheet.name)

'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = "Hyperlink"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Path"
ActiveWorkbook.ActiveSheet.Range("C1").value = "FileName"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Extension"
ActiveWorkbook.ActiveSheet.Range("E1").value = "Size"
ActiveWorkbook.ActiveSheet.Range("F1").value = "Date/Time"
Range("A1:E1").Font.Bold = True

r = r + 1

On Error Resume Next
Application.StatusBar = strMessage_Wait1
With Application.FileSearch
.NewSearch
.LookIn = Directory
If strFileNameFilter = "*.*" Then _
.FileType = msoFileTypeAllFiles
If Len(strFileNameFilter) = 0 Then _
.FileType = msoFileTypeOfficeFiles
.Filename = strFileNameFilter
.SearchSubFolders = blnSubFolders
.Execute
For i = 1 To .FoundFiles.Count
strFilename = ""
strPath = ""
For y = Len(.FoundFiles(i)) To 1 Step -1
If Mid(.FoundFiles(i), y, 1) = _
Application.PathSeparator Then
Exit For
End If
strFilename = _
Mid(.FoundFiles(i), y, 1) & strFilename
Next y
strPath = _
Left(.FoundFiles(i), _
Len(.FoundFiles(i)) - Len(strFilename))
strExtension = ""
For y = Len(strFilename) To 1 Step -1
If Mid(strFilename, y, 1) = "." Then
If Len(strFilename) - y < 0 Then
strExtension = Right(strFilename, _
Len(strFilename) - y)
strFilename = Left(strFilename, y - 1)
Exit For
End If
End If
Next y
Cells(r, 1) = .FoundFiles(i)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), _
Address:=.FoundFiles(i)
Cells(r, 2) = strPath
Cells(r, 3) = strFilename
Cells(r, 4) = strExtension
Cells(r, 5) = FileLen(.FoundFiles(i))
Cells(r, 6) = FileDateTime(.FoundFiles(i))
r = r + 1
Next i
End With

'formatting
Application.StatusBar = strMessage_Wait2
ActiveWindow.Zoom = 75
Columns("E:E").Select
With Selection
.NumberFormat = _
"_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
End With
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Columns("A:F").EntireColumn.AutoFit
Columns("A:A").Select
If Selection.ColumnWidth 12 Then
Selection.ColumnWidth = 12
End If

Range("A2").Select
ActiveWindow.FreezePanes = True

Rows("1:1").Select
Selection.Insert Shift:=xlDown

dblLastRow = 65000

ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False
If Len(strFileNameFilter) = 0 Then
strFileNameFilter = "All MSOffice products"
End If
If blnSubFolders Then
Directory = "(including Subfolders) - " & Directory
End If

Application.ActiveCell.Formula = "=SUBTOTAL(3,A3:A" & _
dblLastRow & ") & " & Chr(34) & _
" files(s) found for Criteria: " & _
Directory & strFileNameFilter & Chr(34)
Selection.Font.Bold = True

Range("B3").Select
Selection.Sort Key1:=Range("B3"), _
Order1:=xlAscending, Key2:=Range("A3") _
, Order2:=xlAscending, HEADER:=xlGuess, _
OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom

Range("A3").Select

Application.Dialogs(xlDialogWorkbookName).Show

Exit_ListFiles:
Application.StatusBar = False
Exit Sub

Err_ListFiles:
MsgBox "Error: " & Err & " - " & Err.Description
Resume Exit_ListFiles

End Sub

'================================================= ==
Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim iFileSystemDirectoriesOnly As Long
Dim iDialogType As Long
Dim iBrowseForComputers As Long
Dim iBrowseForPrinters As Long
Dim iBrowseIncludesFiles As Long
Dim Path As String
Dim r As Long, x As Long, Pos As Integer

iFileSystemDirectoriesOnly = 0
iDialogType = 0
iBrowseForComputers = 0
iBrowseForPrinters = 0
iBrowseIncludesFiles = 0
'- - - - - - - - - - - - - - - - -
' Only return file system directories.
iFileSystemDirectoriesOnly = &H1
' Dialog style with context menu and resizability
' iDialogType = &H40
' Only returns computers
' iBrowseForComputers = &H1000
' Only return printers
' iBrowseForPrinters = &H2000
' The browse dialog will display files as well as folders
' iBrowseIncludesFiles = &H4000

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
' bInfo.ulFlags = &H1
bInfo.ulFlags = _
iFileSystemDirectoriesOnly + _
iDialogType + _
iBrowseForComputers + _
iBrowseForPrinters + _
iBrowseIncludesFiles

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
Pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, Pos - 1)
Else
GetDirectory = ""
End If
End Function
'================================================= ==





"Littlecleavesy" wrote:

I've just spent the best part of a day entering hyperlinks to files in a
shared drive - eg '\\servername\drive\filename.pdf'
After closing the worksheet and opening it up again, I now find that Excel
has amended all the links to '../../drive/filename.pdf' so that when I click
the link it thinks I'm looking for a website and comes up with the error
message - 'The address of the site is not valid. Check the address and try
again.'
I've tried changing one back but the same thing happened as soon as I closed
it and opened it again.
HELP!