Many thanks bob, works just fine

stuart


"Bob Phillips" wrote in message
...
Stuart,

Took me a long time to do it, but here is an app that should do it

Option Explicit

'----------------------------------------------------------------
Sub CheckButtons()
'----------------------------------------------------------------
Dim shp As Shape
Dim sTopLeft As String
Dim fOK As Boolean
Dim i As Long
Dim aryDetails
Dim sMessage As String

ReDim aryDetails(2, 0)
aryDetails(0, i) = "Sheet"
aryDetails(1, i) = "Button"
aryDetails(2, i) = "Routine"

For Each shp In ActiveSheet.Shapes

sTopLeft = ""
On Error Resume Next
sTopLeft = shp.TopLeftCell.Address
'Autofilter and Data Validation dropdowns
'don't seem to have a topleftcell address.
On Error GoTo 0

If shp.Type = msoFormControl Then
If ((shp.FormControlType < xlDropDown) Or _
sTopLeft < "") Then
If shp.OnAction < "" Then
i = UBound(aryDetails, 2) + 1
ReDim Preserve aryDetails(2, i)
aryDetails(0, i) = shp.Parent.Name
aryDetails(1, i) = shp.Name
aryDetails(2, i) = shp.OnAction
End If
End If
ElseIf shp.Type = msoOLEControlObject Then
ActiveXEvents shp, aryDetails
End If

Next shp

For i = LBound(aryDetails, 2) To UBound(aryDetails, 2)
sMessage = sMessage & aryDetails(0, i) & vbTab & _
aryDetails(1, i) & vbTab & _
aryDetails(2, i) & vbCrLf
Next i
MsgBox sMessage

End Sub


'----------------------------------------------------------------
Private Sub ActiveXEvents(ByVal Ctl, ByRef aryDetails)
'----------------------------------------------------------------
Dim aryEvents
Dim i As Long
Dim j As Long

aryEvents = Array("_Activate", "_BeforeDoubleClick", _
"_BeforeRightClick", "_Calculate", _
"_Change", "_FollowHyperlink", _
"_SelectionChange")

j = UBound(aryDetails, 2)

For i = LBound(aryEvents) To UBound(aryEvents)
If ProcedureExists(Ctl.Name & aryEvents(i), Ctl.Parent.CodeName, _
Ctl.Parent.Parent) Then
j = j + 1
ReDim Preserve aryDetails(2, j)
aryDetails(0, j) = Ctl.Parent.Name
aryDetails(1, j) = Ctl.Name
aryDetails(2, j) = Ctl.Name & aryEvents(i)
End If
Next i

End Sub


'----------------------------------------------------------------
Function ModuleExists(ModuleName As String, _
Optional wb As Workbook) As Boolean
'----------------------------------------------------------------
If wb Is Nothing Then
Set wb = ThisWorkbook
End If

On Error Resume Next
ModuleExists = Len( _
wb.VBProject.VBComponents(ModuleName).Name) < 0
End Function


'----------------------------------------------------------------
Function ProcedureExists(ProcedureName As String, _
ModuleName As String, _
Optional wb As Workbook) As Boolean
'----------------------------------------------------------------
If wb Is Nothing Then
Set wb = ThisWorkbook
End If

On Error Resume Next
If ModuleExists(ModuleName) = True Then
ProcedureExists = wb.VBProject.VBComponents(ModuleName) _
.CodeModule.ProcStartLine(ProcedureName, 0) < 0
End If
End Function



--

HTH

RP
(remove nothere from the email address if mailing direct)


"Stuart" wrote in message
...
Is it possable to write a list of all the objects within a workbook and
any
links that they may have with Macros (subs).

To explain the problem, I have a very important workbook that has been
written over many many years, it now contains about 300 macros running
around 20000 lines of code. Some of these macros are undoubtedly no
longer
used, and before I delete any, I wish to check that they are not linked
to
any buttons or objects anywhere within the workbook, I can easily check
the
modules to see if they are called from other macros however I would like
to
check that no button still points to them!