Sub FarbeErsetzen()
Dim sld As Slide
Dim oshp As Shape
Dim oshpR As ShapeRange
Dim lngCol_Alt As Long
Dim iR_Alt As Integer
Dim iG_Alt As Integer
Dim iB_Alt As Integer
Dim lngCol_Neu As Long
Dim iR_Neu As Integer
Dim iG_Neu As Integer
Dim iB_Neu As Integer
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange.Count <> 1 Then
MsgBox "Es muss ein Objekt ausgewählt sein.", vbCritical
Exit Sub
ElseIf ActiveWindow.Selection.Type <> ppSelectionShapes Then
MsgBox "Es muss ein Objekt ausgewählt sein.", vbCritical
Exit Sub
Else
Set oshpR = ActiveWindow.Selection.ShapeRange
lngCol_Alt = oshpR.Fill.ForeColor.RGB
iR_Alt = lngCol_Alt Mod 256
iG_Alt = (lngCol_Alt \ 256) Mod 256
iB_Alt = (lngCol_Alt \ 256 \ 256) Mod 256
ActiveWindow.Selection.Unselect
Debug.Print sh
Do While ActiveWindow.Selection.Type <> ppSelectionShapes
DoEvents
Loop
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
Set oshpR = ActiveWindow.Selection.ShapeRange
lngCol_Neu = oshpR.Fill.ForeColor.RGB
iR_Neu = lngCol_Neu Mod 256
iG_Neu = (lngCol_Neu \ 256) Mod 256
iB_Neu = (lngCol_Neu \ 256 \ 256) Mod 256
End If
End With
ActiveWindow.Selection.Unselect
For Each sld In ActivePresentation.Slides
For Each oshp In sld.Shapes
With oshp
If .Fill.ForeColor.RGB = RGB(iR_Alt, iG_Alt, iB_Alt) Then
.Fill.ForeColor.RGB = RGB(iR_Neu, iG_Neu, iB_Neu)
End If
End With
Next oshp
Next sld
End If
Exit Sub
ErrorHandler:
MsgBox "Es muss ein Objekt ausgewählt sein.", vbCritical
End Sub