Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Forum-Regeln :: FAQ :: Forum-Suche :: Mitgliederliste :: Benutzergruppen :: Favoriten ::  Registrieren :: Profil :: Briefkasten :: Login
Hintergrundfarbe von gewissen Shapes ändern
Office Forum -> Powerpoint Forum -> PowerPoint VBA (Makros)
zurück: Mit PP VBA Excel und Word Datei bearbeiten weiter: Es gibt keine neueren Themen in diesem Forum. Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Offen Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
ExcelTüftler
Excel-VBA "Rumspieler"


Verfasst am:
28. Apr 2014, 13:04
Rufname: Daniel
Wohnort: Kehl am Rhein

Hintergrundfarbe von gewissen Shapes ändern - Hintergrundfarbe von gewissen Shapes ändern

 Nach oben
       Version: Office 2003
Hi Miteinander!

Ausgangssituation:
Ich habe Flussdiagramme über mehrere Slides verteilt.
Die einzelnen "Shapes" sind über die Hintergrundfarbe verschiedenen Abteilungen zugeordnet.
Nun habe ich beim Druck bzw. der Bildschirmpräsentation festgestellt, dass ich die Farben unglücklich gewählt habe. (sie sind zu schwer zu unterscheiden)

Idee:
1. Ich klicke ein "Shape" an.
2. Ich merke mir Hintergrundfarbe, Fontfabe und Transparency
3. Ich ändere die Farbe etc.
4. VBA ändert alle anderen Shapes, die die gemerkten Eigenschaften haben.

Mein Ansatz:
Ich hab's mal so angefangen:
1. Ich öffne eine Userform nonModal und selektiere eine shape.
2. Per Button holt er mir die Infos in Labels bzw. Variablen.
3. Mittels For schlaifen gehe ich durch Slides und shapes und suche nach passenden Eigenschaften.

Probleme:
-Ich bekomm die FontFarbe nicht raus
-Er nimmt auch Lines - die ich ja gar nicht will
- Ich glaube, dass er gruppierte Objekte nicht berücksichtigt...

Kann mir da jemand weiterhelfen?!?

(hier mal mein Code... - Sorry - ich bin eigentlich in Excel zu Hause...)

Code:
Option Explicit
Dim HasFormat As Boolean
Dim Arr As Variant


Private Sub CB_Exit_Click()
    Unload Me
End Sub

Private Sub CB_GetFormat_Click()
    Dim shp As ShapeRange
    Dim SH As Shape
    Dim SL As Slide
    Dim cnt As Integer
    Dim FC As Double
    Dim BC As Double
    Dim P As Double
    Dim v As Variant
   
    cnt = 0
    Set shp = ActiveWindow.Selection.ShapeRange
    BC = shp.Fill.BackColor
    P = Round(shp.Fill.Transparency, 2)
   
    LB_BackColor.Caption = BC
    LB_Transparency = Format(P, "0%")
    For Each SL In ActivePresentation.Slides
        For Each SH In SL.Shapes
            If Not SH.Type = msoGroup Then
                If SH.Fill.BackColor.RGB = BC And Round(SH.Fill.Transparency, 2) = P And SH.Type <> shp.Type Then
                    If Not IsArray(Arr) Then
                        ReDim Arr(0)
                    Else
                        ReDim Preserve Arr(UBound(Arr) + 1)
                    End If
                    Arr(UBound(Arr)) = SH.Name & "|" & SH.Parent.Name
                End If
            End If
        Next
    Next
End Sub

Private Sub UserForm_Initialize()
    HasFormat = False
End Sub

_________________
Gruß Daniel

P.S. Nein, das ist kein Pfusch... das ist Improvisation! ;o)
ExcelTüftler
Excel-VBA "Rumspieler"


Verfasst am:
28. Apr 2014, 16:32
Rufname: Daniel
Wohnort: Kehl am Rhein

AW: Hintergrundfarbe von gewissen Shapes ändern - AW: Hintergrundfarbe von gewissen Shapes ändern

 Nach oben
       Version: Office 2003
OK... frei nach unten stehendem Motto sieht's so aus:

Vorgehensweise:
1. UserForm1 starten
2. ein Shape, dessen Farbe, Transparenz und /oder Schriftfarbe geänderd werden soll auswählen
3. "Format holen" klicken -> MsgBog zeigt an, wieviele Shapes betroffen wären
4. Farbe des Shapes ändern
5. "Ersetzen" klicken -> Farben aller betroffenen Shapes wird angepasst
6. "Beenden" klicken

Fertig...

Das hat zwar was gedauert - aber besser als die ganzen Shapes händisch zu ändern... (auch mit Format-Paste wäre das ne heiden Arbeit!)

Code:
Option Explicit

Dim Shp As ShapeRange
Dim Arr As Variant

Private Sub CB_Exit_Click()
    Unload Me
End Sub

Private Sub CB_GetFormat_Click()
    Dim SH As Shape
    Dim SL As Slide
    Dim v As Variant
   
    Arr = ""
    Set Shp = ActiveWindow.Selection.ShapeRange
    LB_FontColor = Shp.TextFrame.TextRange.Font.Color.RGB
    LB_ForeColor.Caption = Shp.Fill.ForeColor.RGB
    LB_Transparency = Format(Round(Shp.Fill.Transparency, 2), "0%")
    For Each SL In ActivePresentation.Slides
        For Each SH In SL.Shapes
            If SH.Type = msoGroup Then
                For Each v In SH.GroupItems
                    Arr = PackShapesInArr(Arr, v.Parent.Name & "|" & v.Name)
                Next
            Else
                    Arr = PackShapesInArr(Arr, SH.Parent.Name & "|" & SH.Name)
            End If
        Next
    Next
    MsgBox UBound(Arr) + 1 & " Shapes found", vbInformation, "Get format"
End Sub

Private Sub CB_Replace_Click()
    Dim v As Variant
    Dim HelpArr As Variant
    Dim SL As Slide
   
    If IsArray(Arr) Then
        For Each SL In ActivePresentation.Slides
            HelpArr = ""
            For Each v In Arr
            If Split(v, "|")(0) = SL.Name Then
                If Not IsArray(HelpArr) Then
                    ReDim HelpArr(0)
                Else
                    ReDim Preserve HelpArr(UBound(HelpArr) + 1)
                End If
                HelpArr(UBound(HelpArr)) = Split(v, "|")(1)
            End If
            Next
            If IsArray(HelpArr) Then
                With SL.Shapes.Range(HelpArr)
                    .Fill.ForeColor.RGB = Shp.Fill.ForeColor.RGB
                    .Fill.Transparency = Round(Shp.Fill.Transparency, 2)
                    .TextFrame.TextRange.Font.Color.RGB = Shp.TextFrame.TextRange.Font.Color.RGB
                End With
            End If
        Next
    End If
End Sub

Private Function PackShapesInArr(Arr As Variant, v As Variant) As Variant
    Dim isOk As Boolean
   
    With ActivePresentation.Slides(Split(v, "|")(0)).Shapes(Split(v, "|")(1))
        If .Type = msoAutoShape And _
            Round(.Fill.Transparency, 2) = Round(Shp.Fill.Transparency, 2) And _
            .Fill.ForeColor.RGB = Shp.Fill.ForeColor.RGB Then
            If .HasTextFrame Then
                If .TextFrame.TextRange.Font.Color.RGB = Shp.TextFrame.TextRange.Font.Color.RGB Then
                    isOk = True
                End If
            End If
        End If
    End With
    If isOk Then
        If Not IsArray(Arr) Then
            ReDim Arr(0)
        Else
            ReDim Preserve Arr(UBound(Arr) + 1)
        End If
        Arr(UBound(Arr)) = v
    End If
    PackShapesInArr = Arr
End Function


(hmmm... ich wollte noch ein Screenshot anhängen - sagt aber "Upload Error"...)
_________________
Gruß Daniel

P.S. Nein, das ist kein Pfusch... das ist Improvisation! ;o)
Neues Thema eröffnen   Neue Antwort erstellen     Nach oben Alle Zeiten sind
GMT + 1 Stunde
Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Powerpoint Präsentationen: Farben in bestehenden Diagrammen in ganzer Datei ändern 3 kay.one 1800 13. Okt 2010, 20:07
Ursl Farben in bestehenden Diagrammen in ganzer Datei ändern
Keine neuen Beiträge Powerpoint Präsentationen: Text im Master: "Titel durch Klicken hinzufügen" ä 2 dutchtee 3433 03. Sep 2010, 12:33
dutchtee Text im Master: "Titel durch Klicken hinzufügen" ä
Keine neuen Beiträge Powerpoint Präsentationen: Inhalt eines Fensters einer Folie ändern 1 FrauFrühling 493 18. Jan 2010, 18:08
Ute-S Inhalt eines Fensters einer Folie ändern
Keine neuen Beiträge Powerpoint Präsentationen: Animation: Beschriftung eines Rechtecks ändern 1 FlowB 1294 15. Okt 2009, 22:10
Billii Animation: Beschriftung eines Rechtecks ändern
Keine neuen Beiträge Powerpoint Präsentationen: Farbe einer Formel ändern 2 Andi07 4550 08. Sep 2009, 16:14
Gast Farbe einer Formel ändern
Keine neuen Beiträge Powerpoint Präsentationen: HILFE - Zelle ändern von einer Excel-Verknüpfung 0 abuecken 994 29. Jul 2009, 11:16
abuecken HILFE - Zelle ändern von einer Excel-Verknüpfung
Keine neuen Beiträge Powerpoint Präsentationen: Schriftarten und Formate ändern sich bei jedem öffnen 1 ichbindat 1703 26. Apr 2009, 10:46
ichbindat Schriftarten und Formate ändern sich bei jedem öffnen
Keine neuen Beiträge Powerpoint Präsentationen: Standardsprache in Powerpoint ändern 0 stimmungshoch 5049 14. Apr 2009, 12:40
stimmungshoch Standardsprache in Powerpoint ändern
Keine neuen Beiträge Powerpoint Präsentationen: Farbe des Hyperlinks ändern ohne Akzentfarbe zu ändern...? 2 Schnuddelpferd 4238 06. Apr 2009, 17:15
Schnuddelpferd Farbe des Hyperlinks ändern ohne Akzentfarbe zu ändern...?
Keine neuen Beiträge Powerpoint Präsentationen: *T*PowerPoint 2007 Bildformatvorlage ändern 1 WhiteShadow 1902 12. Jan 2009, 18:30
Ute-S *T*PowerPoint 2007 Bildformatvorlage ändern
Keine neuen Beiträge Powerpoint Präsentationen: Name einer Designvorlage ändern 2 Sarah24 4952 23. Feb 2008, 14:27
Sarah24 Name einer Designvorlage ändern
Keine neuen Beiträge Powerpoint Präsentationen: Skalierung einer Gruppierung ändern 1 Enrico1704 5059 25. Jan 2008, 19:16
Ute-S Skalierung einer Gruppierung ändern
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft-Excel Diagramme