Hintergrundfarbe von gewissen Shapes ändern
|
Autor |
Nachricht |
ExcelTüftler
Excel-VBA "Rumspieler"

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