AW: Prozeduren (Makros) zu Shapes löschen
20.08.2009 13:30:15
fcs
llo Beni,
für nicht gruppierte Shapes geht folgende Lösung, um das einem Shape zugeordnete Makro zu löschen.
Voraussetzung: Makros beinden sich in der gleichen Arbeitsmappe wie die Shape-Objekt.
Es können auch mehrere selektierte Shapes gleichzeitig bearbeitet werden.
Gruß
Franz
'Erstellt unter Excel 2003
'ggf. im VBA-Editor den Verweis setzen auf _
Microsoft Visual Basic for Application Extensibility ... _
Microsoft Forms x.y Object Library
Sub ShapeMakroWeg()
Dim objShape As Object, shShape As Shape
Dim strProcedure As String
On Error GoTo Fehler
Set objShape = Selection
If Not objShape Is Nothing Then
For Each shShape In objShape.ShapeRange
With shShape
strProcedure = .OnAction
' MsgBox strProcedure
If strProcedure "" Then
'Dateinamen vom Prozedurnamen abtrennen
strProcedure = Mid(strProcedure, InStr(1, strProcedure, "!") + 1)
'Makrozuweisung zum Shape löschen
.OnAction = ""
ProcedureWeg (strProcedure)
End If
End With
Next
End If
Fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End If
End With
End Sub
Sub ProcedureWeg(strProcedure As String)
'strProcedur = Name der zu löschenden Prozedur
Dim objVB_Comp As Object
Dim Zeile As Long, Zeilen As Long
Dim objProcedureKind As VBIDE.vbext_ProcKind
On Error GoTo Fehler
' MsgBox strProcedure
With ActiveWorkbook.VBProject
'VBA-Komponenten durchsuchen
For Each objVB_Comp In .VBComponents
With objVB_Comp.CodeModule
'Prüfen, ob Procedur im Modul und Startzeile ermitteln
Zeile = 1
If .Find(Target:="Sub " & strProcedure, StartLine:=Zeile, StartColumn:=1, _
EndLine:=.CountOfLines, EndColumn:=80, WholeWord:=False) = True Then
'Zeile mit Prozedurbeginn suchen
If MsgBox("Prozedur """ & strProcedure & """ wirklich löschen?", _
vbQuestion + vbDefaultButton2 + vbOKCancel, _
"Makro zugewiesen zu Shape löschen") = vbCancel Then Exit For
'Anzahl Zeilen der Prozedur
objProcedureKind = vbext_pk_Proc
Zeilen = .ProcCountLines(ProcName:=strProcedure, ProcKind:=objProcedureKind)
'Code Zeilen der Prozedur löschen
.DeleteLines Zeile, Zeilen - 1
Exit For
End If
End With
Next
End With
Fehler:
With Err
If .Number 0 Then
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End If
End With
End Sub