Prev: Reverse output of the Linest function
Next: Cannot start the source application for this object
From: Littlecleavesy on 19 Oct 2006 04:26
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!
From: Gary L Brown on 19 Oct 2006 16:07
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
gary_brown(a)ge_NOSPAM.com
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) = Fi
 | 
Pages: 1
Prev: Reverse output of the Linest function
Next: Cannot start the source application for this object