' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Dim iFound As Integer
'
'Quelle http://www.bmsltd.ie/MVP/Default.htm
'
Private Function CheckDelete(Where As String, What As String)
Dim iResp As Integer
iFound = iFound + 1
iResp = MsgBox("Found a link in " & Where & ":" & Chr(10) & What & Chr(10) & "Shall I delete it?", vbYesNoCancel, "Link Finder")
Select Case iResp
Case vbCancel
Application.StatusBar = False
End
Case vbYes
CheckDelete = True
Case vbNo
CheckDelete = False
End Select
End Function
Sub FindLinks()
Dim obj As Object, oSheet As Object, oSeries As Object
Dim iOLEfound As Integer, stMsg As String
Dim rCell As Range, rFirst As Range, rToDo As Range
Dim rDone As Range, rAll As Range, rArea As Range
Static LinkString As String
iFound = 0
If IsEmpty(ActiveWorkbook.LinkSources()) Then
MsgBox "There are no links from this workbook"
Exit Sub
End If
LinkString = InputBox("Name of file to which links refer?" & _
Chr(10) & "Do not include path if file is open", Default:=LinkString, _
Title:="Link Finder")
If LinkString = "" Then Exit Sub
Application.StatusBar = "Looking for links in workbook names"
' first look for names
For Each obj In ActiveWorkbook.Names
If InStr(obj.RefersTo, LinkString) > 0 Then
stMsg = ""
If obj.Visible = False Then stMsg = stMsg & "hidden "
If CheckDelete(stMsg & "name " & obj.Name, obj.RefersTo) Then obj.Delete
End If
Next obj
' now scan each sheet in turn
For Each oSheet In ActiveWorkbook.Sheets
Application.StatusBar = "Looking for links in sheet " & oSheet.Name
iOLEfound = 0
If TypeName(oSheet) <> "Module" Then
For Each obj In oSheet.DrawingObjects
' any drawing object could be linked to a macro
If InStr(obj.OnAction, LinkString) > 0 Then
If CheckDelete("OnAction of " & TypeName(obj) & " '" & obj.Name & "' in " & oSheet.Name, obj.OnAction) Then obj.OnAction = ""
End If
' some drawing objects have formula properties
Select Case TypeName(obj)
Case "TextBox", "Picture", "Button"
If InStr(obj.Formula, LinkString) > 0 Then
If CheckDelete("formula of " & TypeName(obj) & " '" & obj.Name & "' in " & oSheet.Name, obj.Formula) Then obj.Formula = ""
End If
Case "OLEObject"
' can't get to the formula of an OLEObject - so report at end
iOLEfound = iOLEfound + 1
Case "ChartObject"
For Each oSeries In obj.Chart.SeriesCollection
If InStr(oSeries.Formula, LinkString) > 0 Then
If CheckDelete("series " & oSeries.Name & " in Chart " & obj.Name & " on sheet " & oSheet.Name, oSeries.Formula) Then oSeries.Formula = ""
End If
Next oSeries
End Select
Next
If TypeName(oSheet) = "Worksheet" Then
' look in cell formulae
Application.ScreenUpdating = False ' otherwise screen flashes
Set rCell = Nothing
On Error Resume Next
Set rCell = oSheet.UsedRange.Find(LinkString, oSheet.UsedRange.Range("A1"), xlFormulas, xlPart, xlByRows, xlNext)
On Error GoTo 0
If Not rCell Is Nothing Then
Set rFirst = rCell
Set rAll = rCell
Do
Set rCell = oSheet.UsedRange.FindNext(rCell)
Set rAll = Union(rAll, rCell)
Loop Until rCell.Address = rFirst.Address
Application.ScreenUpdating = True
For Each rArea In rAll.Areas
Set rDone = rArea.Cells(1, 1)
Set rToDo = rArea.Cells(1, 1)
Do
For Each rCell In rArea.Cells
If Intersect(rDone, rCell) Is Nothing Then
If rToDo Is Nothing Then
Set rToDo = rCell
ElseIf rCell.FormulaR1C1 = rToDo.Cells(1, 1).FormulaR1C1 Then
Set rToDo = Union(rToDo, rCell)
End If
End If
Next rCell
stMsg = "cell "
If rToDo.Cells.Count > 1 Then stMsg = "cells "
If CheckDelete(stMsg & oSheet.Name & "!" & rToDo.Address, rToDo.Range("A1").Formula) Then
rToDo.Formula = rToDo.Value
End If
Set rDone = Union(rDone, rToDo)
Set rToDo = Nothing
Loop Until rDone.Address = rArea.Address
Next rArea
End If
ElseIf TypeName(oSheet) = "Chart" Then
' look in chart series
For Each oSeries In oSheet.SeriesCollection
If InStr(oSeries.Formula, LinkString) > 0 Then
If CheckDelete("series " & oSeries.Name & " in Chart " & _
obj.Name, oSeries.Formula) Then oSeries.Formula = ""
End If
Next oSeries
ElseIf TypeName(oSheet) = "DialogSheet" Then
' look in on action of dialog frame
If InStr(oSheet.DialogFrame.OnAction, LinkString) > 0 Then
If CheckDelete("dialog frame of " & oSheet.Name, oSheet.DialogFrame.OnAction) Then oSheet.DialogFrame.OnAction = ""
End If
End If
End If
If iOLEfound = 1 Then
MsgBox "There is an OLE Object on sheet " & oSheet.Name & " which I could not check"
oSheet.OLEObjects.Select
ElseIf iOLEfound > 1 Then
MsgBox "There are " & iOLEfound & " OLE Objects on sheet " & oSheet.Name & " which I could not check"
oSheet.OLEObjects.Select
End If
Next oSheet
If iFound = 0 Then MsgBox "No links found to " & LinkString, vbInformation, "Link Finder"
Application.StatusBar = False
End Sub