AW: Anzeige Information zu Schaltflächen Formen
02.12.2018 02:55:19
fcs
hallöchen,
hier der Code mit 2 Ergänzungen
1. Die Beschriftung der Schaltflächen wird angezeigt.
2. Andere Formen (Rechteck, Kreis etc) denen ein Makro zugewiesen ist werden ebenfalls gelistet.
Gruß
Franz
Sub StatusSchaltflaechen()
Dim wks As Worksheet
Dim objSh As Shape
Dim sName$, bolVisible, sTopLeft$, varHoehe, varBreite, sMakro$, sInfo$, sBeschriftung$
Dim arrShData(), iSh As Integer
Dim varType As MsoShapeType, varSubType, bolListen As Boolean, bolSkip As Boolean
Dim sMsgText$
Set wks = ActiveSheet
iSh = 0
ReDim arrShData(1 To 8, 0 To 0)
arrShData(1, iSh) = "Name"
arrShData(2, iSh) = "Beschriftung"
arrShData(3, iSh) = "sichtbar"
arrShData(4, iSh) = "Zelle linksoben"
arrShData(5, iSh) = "Breite"
arrShData(6, iSh) = "Höhe"
arrShData(7, iSh) = "OnActio-Makro"
arrShData(8, iSh) = "Type"
sInfo = ActiveWorkbook.Name & "!" & wks.Name & " - Schaltflächen"
For Each objSh In wks.Shapes
With objSh
sName = .Name
sTopLeft = .TopLeftCell.Address(False, False, xlA1)
varHoehe = .Height
varBreite = .Width
bolVisible = .Visible
varType = .Type
bolListen = False
sMakro = ""
sBeschriftung = ""
Select Case varType
Case msoOLEControlObject
If InStr(.OLEFormat.progID, "CommandButton") > 0 Then
varSubType = "Active-X-Schaltfläche"
sBeschriftung = .OLEFormat.Object.Object.Caption
bolListen = True
End If
Case msoFormControl
Select Case .FormControlType
Case xlButtonControl
varSubType = "Formular-Schaltfläche"
sMakro = .OnAction
sBeschriftung = .TextFrame.Characters.Text
bolListen = True
End Select
Case msoAutoShape 'andere Formen mit Makro-Zuweisung
If .OnAction "" Then
varSubType = "allgemeine Form"
sBeschriftung = .TextFrame.Characters.Text
sMakro = .OnAction
bolListen = True
End If
End Select
End With
If bolListen = True Then
iSh = iSh + 1
ReDim Preserve arrShData(1 To 8, 0 To iSh)
arrShData(1, iSh) = sName: sMsgText = "Name: " & sName
arrShData(2, iSh) = sBeschriftung: sMsgText = _
sMsgText & vbLf & "Beschriftung: " & sBeschriftung
arrShData(3, iSh) = IIf(bolVisible = -1, "Ja", "Nein"): _
sMsgText = sMsgText & vbLf & "sichtbar: " & arrShData(3, iSh)
arrShData(4, iSh) = sTopLeft: sMsgText = sMsgText & vbLf & "Zelle linksoben: " _
& sTopLeft
arrShData(5, iSh) = varBreite: sMsgText = sMsgText & vbLf & "Breite: " & varBreite
arrShData(6, iSh) = varHoehe: sMsgText = sMsgText & vbLf & "Höhe: " & varHoehe
arrShData(7, iSh) = sMakro: sMsgText = sMsgText & vbLf & "OnActio-Makro: " & sMakro
arrShData(8, iSh) = varSubType: sMsgText = sMsgText & vbLf & "Type: " & varSubType
If bolSkip = False Then
If MsgBox(sMsgText, vbOKCancel, "Shape-Infos Blatt: " & wks.Name) = vbCancel _
Then bolSkip = True
End If
End If
Next
If iSh = 0 Then
MsgBox "Im aktiven Tabellenblatt gibt es keine Schaltflächen!"
Else
If MsgBox("Sollen die Daten zu allen Schaltflächen in einem separaten Blatt " _
& "angezeigt werden?", vbQuestion + vbOKCancel) = vbOK Then
Application.Workbooks.Add Template:=xlWBATWorksheet
ActiveWorkbook.Sheets(1).Cells(3, 1).Resize(iSh + 1, 8) = _
Application.WorksheetFunction.Transpose(arrShData)
ActiveWorkbook.Sheets(1).UsedRange.EntireColumn.AutoFit
ActiveWorkbook.Sheets(1).Cells(1, 1) = sInfo
End If
End If
End Sub