De: Bill Manville <Bill-Manville@msn.com>
Objet: Re: Help Finding XLSs with Links
Date : vendredi 13 octobre 2000 09:22

In article <8s5snu$mce$1@slb2.atl.mindspring.net>, Frank Vanek wrote:
> The ideal program would run thru a directory or
> tree structure and identify all XLSs with links.
>
Maybe this is it?:

Dim aFiles() As String, iFiles As Integer

Sub ListAllFilesInDirectoryStructure()
  iFiles = 0
  ListXLSFilesInDirectory "c:\TEMP\"  ' change the top level as you 
wish
  'MsgBox iFiles & " files found"
  ProcessFiles
End Sub
  
Sub ListXLSFilesInDirectory(Directory As String)
  Dim aDirs() As String, iDir As Integer, stFile As String
  
  ' use Dir function to find files and directories in Directory
  ' look for directories and build a separate array of them
  ' note that Dir returns files as well as directories when vbDirectory 
specified
  iDir = 0
  stFile = Directory & Dir(Directory & "*.*", vbDirectory)
  Do While stFile <> Directory
    If Right(stFile, 2) = "\." Or Right(stFile, 3) = "\.." Then
      ' do nothing - GetAttr doesn't like these directories
    ElseIf (GetAttr(stFile) And vbDirectory) = vbDirectory Then
      ' add to local array of directories
      iDir = iDir + 1
      ReDim Preserve aDirs(1 To iDir)
      aDirs(iDir) = stFile
    ElseIf LCase(Right(stFile, 3)) = "xls" Then
      ' add to global array of files
      iFiles = iFiles + 1
      ReDim Preserve aFiles(1 To iFiles)
      aFiles(iFiles) = stFile
    End If
    stFile = Directory & Dir()
  Loop
    
  ' now, for any directories in aDirs call self recursively
  If iDir > 0 Then
    For iDir = 1 To UBound(aDirs)
      ListXLSFilesInDirectory aDirs(iDir) & Application.PathSeparator
    Next iDir
  End If
End Sub

Sub ProcessFiles()
  Dim iFile As Integer
  Dim WB As Workbook
  Dim R As Range
  Dim V
  Dim iLink As Integer
  set WB = Workbooks.Add(xlWorksheet)
  set R = Range("A1")
  Range("A1") = "Source"
  Range("B1") = "Links To"
  Range("C1") = "Info"
  set R = Range("A2")
  For iFile = 1 To iFiles
    Application.ScreenUpdating = False
    On Error Resume Next
    R.Value = aFiles(iFile)
    Workbooks.Open aFiles(iFile), updatelinks:=0, ReadOnly:=True
    If Err <> 0 Then
      R.Offset(, 2) = "Open Failed"
    Else
      On Error GoTo 0
      V = ActiveWorkbook.LinkSources(xlExcelLinks)
      If TypeName(V) = "Empty" Then
        R.Offset(, 2) = "No Excel links"
      Else
        For iLink = LBound(V) To UBound(V)
          R.Offset(, 1) = V(iLink)
          If iLink < UBound(V) Then
            ' prepare for next
            set R = R.Offset(1)
            R.Value = aFiles(iFile)
          End If
        Next
      End If
      If ActiveWorkbook.FullName <> ThisWorkbook.FullName Then
        ActiveWorkbook.Close False
      End If
    End If
    Application.ScreenUpdating = True
    set R = R.Offset(1)
  Next
End Sub

Bill Manville
MVP - Microsoft Excel, Oxford, England
No email replies please - respond to newsgroup
 