AW: Ewald und ich hatten im August über ...
10.09.2014 20:23:20
Ewald
Hallo Ivonne,
eine Kurzbeschreibung
eine Theme Color besteht aus 12 Grundfarben von denen nur 10 im Farbauswahldialog angezeigt werden.(die letzten 2 Farben fehlen, sie sind dem Hyperlink zugeordnet.)
Die weiteren 50 Farben sind jeweils die Grundfarben die mit TintandShade in eine harmonische Abstufung der Farben gebracht werden. Diese Werte sind festcodiert und können in einer Theme ohne VBA nicht geändert werden.
Die Theme Color wird in einer Datei gespeichert, die den englischen Namen des Namens in der Auswahlliste hat. Doch hier ist Vorsicht geboten , es sind abenteuerliche Übersetzungen dabei.
Das Auslesen der Datei nach den Farben bringt aber kein gutes Ergebnis.
Die Farben 1 + 2 und 3 + 4 sind vertauscht (gegenüber dem Farbdialog)
Die Angaben sind Hexwerte und müssen umgerechnet werden.
Dann gibt es Angaben die sich auf die eingestellten Windowsfarben für Fenster und Schrift beziehen und damit auch unterschiedlich sein können.
Neben den Standard kann man aber auch benutzerdefinierte Theme Color erstellen, hier können aber nur die Grundfarben geändert werden.
Außerdem werden die Dateien an unterschiedlichen Dateiorten gespeichert(für 2010)
Standard im Ordner c:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\
Benutzerdefinierte c:\Users\Name\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\
Ein weiteres Hindernis gibt es auch noch, die Standard Theme Color Larissa ist nicht als Datei vorhanden und man kann sie auch nicht mehr so einfach mit VBA laden.
Es bedarf also einiger Vorbereitung bis man die Themen (nenne sie jetzt mal so) auslesen kann.
Von der Theme Larissa muß eine Kopie erstellt werden, damit man sie auslesen kann.(habe sie Standard benannt)
Alle Themen an einem Ort hinterlegen (habe alle in den Standardordner kopiert
Die Hardcodierung der TintandShadewerte auslesen(habe sie dann in ein Array geschrieben.)
Mit folgendem Code kann man dann auslesen.
Public Dateipfad
Public Zeile As Long
Public Dateiname As String
Sub Themen()
Dim Ordner As String
Dim Anzahl As Long
Dim Anzahlxml
Dim Liste As String
Dim i
Dim fo As Object
Dim fi As Object
Dim fso As Object
Ordner = "c:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\"
Zeile = 3
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.GetFolder(Ordner)
For Each fi In fo.Files
Anzahl = Anzahl + 1
Dateiname = LCase(fi.Name)
If Right(Dateiname, 4) = ".xml" Then
Anzahlxml = Anzahlxml + 1
Liste = Liste & Left(fi.Name, Len(fi.Name) - 4) & Chr(13)
Dateipfad = Ordner & Dateiname
Call Schreiben
Zeile = Zeile + 7
End If
Next
ActiveWorkbook.Theme.ThemeColorScheme.Load ("C:\Program Files\Microsoft Office\Document Themes _
14\Theme Colors\Standard.xml")
End Sub
Sub Schreiben()
Dim i
Dim k
Dim x
Dim arr
ReDim arr(1 To 5)
arr(1) = Array(-0.049989319, 0.499984741, -0.99948119, 0.799981689, 0.799981689, 0.799981689, _
0.799981689, 0.799981689, 0.799981689, 0.799981689, 0.799981689, 0.799981689)
arr(2) = Array(-0.149967956, 0.349986267, -0.249946593, 0.599963378, 0.599963378, 0. _
599963378, 0.599963378, 0.599963378, 0.599963378, 0.599963378, 0.599963378, 0.599963378)
arr(3) = Array(-0.249946593, 0.249946593, -0.499984741, 0.399945067, 0.399945067, 0. _
399945067, 0.399945067, 0.399945067, 0.399945067, 0.399945067, 0.399945067, 0.399945067)
arr(4) = Array(-0.349986267, 0.149967956, -0.749961852, -0.249946593, -0.249946593, -0. _
249946593, -0.249946593, -0.249946593, -0.249946593, -0.249946593, -0.249946593, -0.249946593)
arr(5) = Array(-0.499984741, 0.049989319, -0.899960326, -0.499984741, -0.499984741, -0. _
499984741, -0.499984741, -0.499984741, -0.499984741, -0.499984741, -0.499984741, -0.499984741)
ActiveWorkbook.Theme.ThemeColorScheme.Load (Dateipfad)
With Worksheets(1)
.Cells(Zeile, 1).Value = Left(Dateiname, Len(Dateiname) - 4)
.Cells(Zeile, 2).Value = ""
.Cells(Zeile, 3).Value = ThisWorkbook.Theme.ThemeColorScheme.Colors(2)
.Cells(Zeile, 3).Interior.Color = .Cells(Zeile, 3).Value
.Cells(Zeile, 4).Value = ThisWorkbook.Theme.ThemeColorScheme.Colors(1)
.Cells(Zeile, 4).Interior.Color = .Cells(Zeile, 4).Value
.Cells(Zeile, 5).Value = ThisWorkbook.Theme.ThemeColorScheme.Colors(4)
.Cells(Zeile, 5).Interior.Color = .Cells(Zeile, 5).Value
.Cells(Zeile, 6).Value = ThisWorkbook.Theme.ThemeColorScheme.Colors(3)
.Cells(Zeile, 6).Interior.Color = .Cells(Zeile, 6).Value
For i = 7 To 14
.Cells(Zeile, i).Interior.Color = ThisWorkbook.Theme.ThemeColorScheme.Colors(i - 2) 'Colors( _
x)
.Cells(Zeile, i).Value = .Cells(Zeile, i).Interior.Color
Next i
k = Zeile + 1
Cells(k, 3).Resize(UBound(arr, 1), UBound(arr(1), 1) + 1) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
For x = k To k + 4
For i = 3 To 14
.Cells(x, i).Interior.Color = .Cells(Zeile, i).Value
.Cells(x, i).Interior.TintAndShade = .Cells(x, i).Value
.Cells(x, i).Value = .Cells(x, i).Interior.Color
Next
Next
End With
End Sub
Gruß Ewald
