Das liegt wohl daran, dass du oshpR(1) setzt, statt das ausgewählte Objekt zu setzen.
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 ' Error Handling
If ActiveWindow.Selection.ShapeRange.Count <> 1 Then 'Abbruch, falls mehr als ein Objekt ausgewählt ist
MsgBox "Es muss ein Objekt ausgewählt sein.", vbCritical
Exit Sub
ElseIf ActiveWindow.Selection.Type <> ppSelectionShapes Then 'Abbruch, falls keine Autoform ausgewählt ist
MsgBox "Es muss ein Objekt ausgewählt sein.", vbCritical
Exit Sub
Else
Set oshpR = ActiveWindow.Selection.ShapeRange
lngCol_Alt = oshpR.Fill.ForeColor.RGB 'Erfassung der Farbe, die ersetzt werden soll
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 'Erfassung der Farbe, die die alte Farbe ersetzen soll
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 '.Range
For Each oshp In sld.Shapes 'Iteration durch alle Objekte für Abgleich
With oshp
If .Fill.ForeColor.RGB = RGB(iR_Alt, iG_Alt, iB_Alt) Then
' .Select
.Fill.ForeColor.RGB = RGB(iR_Neu, iG_Neu, iB_Neu) 'Falls Objekt mit zu ersetzender Farbe: alte Farbe mit neuer Farbe ersetzen
End If
End With
Next oshp
Next sld
End If
Exit Sub 'Wichtig, da sonst Error Handling-Code ausgeführt wird, obwohl kein Fehler vorliegt
ErrorHandler:
MsgBox "Es muss ein Objekt ausgewählt sein.", vbCritical
'Resume Next
End Sub
|