Drive letters, links

J

Jeff Ericson

We would like to search a folder full of Excel objects and
indentify any that have a link, or drive letter mapping.
Any concepts?
 
D

Dave Peterson

Maybe...
Option Explicit
Sub testme01()

Application.ScreenUpdating = False

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim logWks As Worksheet
Dim oRow As Long
Dim myLinks As Variant

Set logWks = Workbooks.Add(1).Worksheets(1)
With logWks
.Name = "Log_" & Format(Now, "yyyymmdd_hhmmss")
.Range("a1:c1").Value _
= Array("Sequence", "WorkbookName", "Links")
End With
oRow = 1

'change to point at the folder to check
myPath = "c:\my documents\excel\test"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar _
= "Processing: " & myFiles(fCtr) & " at: " & Now
Set tempWkbk = Nothing
On Error Resume Next
Application.EnableEvents = False
Set tempWkbk = Workbooks.Open(Filename:=myPath & myFiles(fCtr), _
UpdateLinks:=0)
Application.EnableEvents = True
On Error GoTo 0

oRow = oRow + 1
logWks.Cells(oRow, 2).Value = myPath & myFiles(fCtr)

If tempWkbk Is Nothing Then
'couldn't open it for some reason
logWks.Cells(oRow, 3).Value = "Error opening workbook"
Else
With tempWkbk
myLinks = .LinkSources
If IsArray(myLinks) Then
logWks.Cells(oRow, 3).Value _
= "Has Links"
End If
.Close SaveChanges:=False
End With
End If
Next fCtr
logWks.UsedRange.Columns.AutoFit
Else
logWks.Parent.Close SaveChanges:=False
End If

With logWks
With .Range("a2:a" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.Formula = "=row()-1"
.Value = .Value
End With
End With

With Application
.ScreenUpdating = True
.StatusBar = False
End With

End Sub
 
G

Gary Brown

VERY Nice Dave.
Will this pick up hyperlinks too?
Sincerely,
Gary Brown
-----Original Message-----
Maybe...
Option Explicit
Sub testme01()

Application.ScreenUpdating = False

Dim myFiles() As String
Dim fCtr As Long
Dim myFile As String
Dim myPath As String
Dim tempWkbk As Workbook
Dim logWks As Worksheet
Dim oRow As Long
Dim myLinks As Variant

Set logWks = Workbooks.Add(1).Worksheets(1)
With logWks
.Name = "Log_" & Format(Now, "yyyymmdd_hhmmss")
.Range("a1:c1").Value _
= Array("Sequence", "WorkbookName", "Links")
End With
oRow = 1

'change to point at the folder to check
myPath = "c:\my documents\excel\test"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

myFile = Dir(myPath & "*.xls")
If myFile = "" Then
MsgBox "no files found"
Exit Sub
End If

'get the list of files
fCtr = 0
Do While myFile <> ""
fCtr = fCtr + 1
ReDim Preserve myFiles(1 To fCtr)
myFiles(fCtr) = myFile
myFile = Dir()
Loop

If fCtr > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Application.StatusBar _
= "Processing: " & myFiles(fCtr) & " at: " & Now
Set tempWkbk = Nothing
On Error Resume Next
Application.EnableEvents = False
Set tempWkbk = Workbooks.Open
Click to expand...
(Filename:=myPath & myFiles(fCtr), _
 
D

Dave Peterson

Nope.

But you could loop though each worksheet looking--something like this could be
incorporated.

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim tempWkbk As Workbook
Dim hyperCtr As Long

Set tempWkbk = ActiveWorkbook 'just for testing

hyperCtr = 0
For Each wks In tempWkbk.Worksheets
hyperCtr = wks.Cells.Hyperlinks.Count
Next wks

MsgBox hyperCtr

End Sub

This looks for the hyperlinks added to cells (via insert|hyperlink). It doesn't
look for the worksheet formula =hyperlink() or hyperlinks lurking behind
objects.
 
G

Gary Brown

How about looping around looking for '.xls' the way Bill Manville does?
Sincerely,
Gary Brown
 
D

Dave Peterson

For hyperlinks?

You can hyperlink to web pages or even other files--not necessarily excel
workbooks.
 
Top