find_links_folder.vbs

' find_links_folder.vbs
' Written by Carol Wapshere, 2008
' Search for .xls files and find links to other documents.

Const REPORT_DIR = "C:\ExcelLinks\"   'The folder where you want to save the lists
Const START_FOLDER = "X:\"  'The folder to search

Dim SUFFIX, FILE_LIST, RESULTS_SOURCELINKS, RESULTS_HYPERLINKS
Dim objList, objFS, objFolder, objFile

SUFFIX = Replace(Replace(START_FOLDER,":",""),"\","_")
FILE_LIST = DIR & SUFFIX & "excel_list.txt"
RESULTS_SOURCELINKS = DIR & SUFFIX & "found_sourcelinks.csv"
RESULTS_HYPERLINKS = DIR & SUFFIX & "found_hyperlinks.csv"
PW_PROTECTED = DIR & SUFFIX & "pw_protected.txt"

Dim arrExcel()

'Log links containing these strings.
'If you want to log all links, there is an If clause to comment out further down
Dim arrBadLinks(1)
arrBadLinks(0) = "OLD_SERVER"
arrBadLinks(1) = "X:\"

count = -1

set objFS = CreateObject("Scripting.FileSystemObject")

'-- Scan from START_FOLDER saving all files with xls in the name

If objFS.FileExists(FILE_LIST) Then
  wscript.echo "Rescan for documents? (y/n)"
  answer = wscript.stdin.Readline
  If answer = "y" Then
    set objList = objFS.OpenTextFile(FILE_LIST,2,true)
    FindExcelDocs
    objList.Close
  End If
Else
  set objList = objFS.OpenTextFile(FILE_LIST,2,true)
  FindExcelDocs
  objList.Close
End If

'Comment out the following lines if you want the script to prompt between finding and checking the documents
'wscript.echo "Start checking documents? (y/n)"
'answer = wscript.stdin.Readline
'If answer <> "y" Then
'  wscript.Quit
'End If

'-- Initialise results files
Set objSourceLinks = objFS.OpenTextFile(RESULTS_SOURCELINKS,2,true)
objSourceLinks.Writeline("Path;Target")
Set objHyperLinks = objFS.OpenTextFile(RESULTS_HYPERLINKS,2,true)
objHyperLinks.Writeline("Path;Worksheet;Link Text;Link Address")
Set objPW = objFS.OpenTextFile(PW_PROTECTED,8,true)

'-- Open each Excel doc, looking for Source Links and Hyperlinks

set objExcel = CreateObject("Excel.Application")
objExcel.Visible = false
objExcel.DisplayAlerts = false

On Error Resume Next

set objList = objFS.OpenTextFile(FILE_LIST,1)
Do Until objList.AtEndOfStream

  path = objList.Readline
  set objFile = objFS.GetFile(path)

    wscript.echo path
    set objWorkbook = objExcel.Workbooks.Open(path,0,true,,"password")
    If objWorkbook.HasPassword Then
      objPW.Writeline(path)
    End If

    '-- Find Source Links
    colLinks = objWorkbook.LinkSources()
    If Not IsEmpty(colLinks) Then
      for i = Lbound(colLinks) to Ubound(colLinks)

        'To find ALL links comment out next two lines and corresponding "Next" and "End If"
        For j = Lbound(arrBadLinks) to Ubound(arrBadLinks)
          If InStr(UCase(colLinks(i)), UCase(arrBadLinks(j))) Then
            wscript.echo "Link: " & colLinks(i)
            objSourceLinks.Writeline(path & ";" & colLinks(i))
            Exit For
          End If
        Next
      Next
    End If

    '-- Check through each worksheet looking for Hyperlinks
    For sheet = 1 to objWorkbook.Worksheets.Count
      wscript.echo "Sheet: " & objWorkbook.Worksheets(sheet).Name
      For Each link in objWorkbook.Worksheets(sheet).Hyperlinks

        'To find ALL links comment out next two lines and corresponding "Next" and "End If"
        For j = Lbound(arrBadLinks) to Ubound(arrBadLinks)
          If InStr(link.Address, UCase(arrBadLinks(j))) Then
            wscript.echo "HyperLink: " & link.Address
            objHyperLinks.Writeline(path & ";" & _
                       objWorkbook.Worksheets(sheet).Name & ";" & _
                       link.TextToDisplay & ";" & _
                       link.Address & ";" & _
         fileDate)
          End If
        Next
      Next
    Next

    objExcel.DisplayAlerts = false
    objExcel.ActiveWorkbook.Close(false)

Loop

objSourceLinks.Close
objHyperLinks.Close

'-- SUBROUTINES --

Sub FindExcelDocs
  set objFolder = objFS.GetFolder(START_FOLDER)

  'Files in root of folder
  For each objFile in objFolder.Files
    If Instr(LCase(objFile.Name),".xls") Then
      fileDate = objFile.DateLastModified

      'Modify the next line to change date range, or comment out to check all files
      If (DatePart("yyyy",fileDate) = "2008") Then
        wscript.echo objFile.Path
        'count = count + 1
        'ReDim Preserve arrExcel(count + 1)
        'arrExcel(count) = objFile.Path
        objList.Writeline(objFile.Path)
      End If
    End If
  Next
 
  'Files in subfolders
  SearchSubFolders objFolder

End Sub

Sub SearchSubFolders(Folder)
  For Each Subfolder in Folder.Subfolders
    set objFolder = objFS.GetFolder(Subfolder.Path)
  For each objFile in objFolder.Files
    If Instr(LCase(objFile.Name),".xls") Then
      fileDate = objFile.DateLastModified

      'Modify the next line to change date range, or comment out to check all files
      If (DatePart("yyyy",fileDate) = "2008") Then
        wscript.echo objFile.Path
        'count = count + 1
        'ReDim Preserve arrExcel(count + 1)
        'arrExcel(count) = objFile.Path
        objList.Writeline(objFile.Path)
      End If
    End If
  Next
    wscript.echo
    SearchSubFolders Subfolder
  Next
End Sub