Hallo,
@Ivonne
damit in der Userform die Colorthemenauswahlnamen erscheinen, ersetze im Modul1 die Function lesen durch diese.
Function lesen(Index As Long) As String
Dim Ordner As String
Dim Liste As String
Dim myarr(42) As Variant
Dim myarr2 As Variant
Dim Text As String
Dim i As Long
Dim k As Long
Dim fo As Object
Dim fi As Object
Dim fso As Object
ReDim myarr2(2)
myarr2(0) = Array("Adjacency", "Alte Farben", "Angles", "Apex", "Apothecary", "Aspect", "Austin" _
, "Black Tie", "Civic", "Clarity", "Composite", "Concourse", "Couture", "Elemental", "Equity", "Essential", "Executive", "Flow", "Foundry", "Grayscale", "Grid", "Hardcover", "Horizon", "Median", "Metro", "Module", "Newsprint", "Opulent", "Oriel", "Origin", "Paper", "Perspective", "Pushpin", "Slipstream", "Solstice", "Standard", "Technic", "Thatch", "Trek", "Urban", "Verve", "Waveform")
myarr2(1) = Array("Nähe", "Alte Farben", "Winkel", "Ananke", "Apotheke", "Ganymed", "Austin", " _
Smoking", "Cronus", "Klarheit", "Zusammengesetzt", "Deimos", "Couture", "Elementar", "Dactylos", "Essenz", "Executive", "Hyperion", "Phoebe", "Graustufe", "Raster", "Hardcover", "Horizont", "Galathea", "Iapetus", "Modul", "Zeitungspapier", "Lysithea", "Nereus", "Okeanos", "Papier", "Perspective", "Pin", "Slipstream", "Nyad", "Larissa", "Haemera", "Stroh", "Metis", "Rhea", "Telesto", "Wellenform")
Ordner = "c:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.GetFolder(Ordner)
i = 0
For Each fi In fo.Files
myarr(i) = Left(fi.Name, Len(fi.Name) - 4)
i = i + 1
Next
lesen = myarr(Index - 1)
For k = LBound(myarr2(0)) To UBound(myarr2(0))
If myarr2(0)(k) = lesen Then Text = myarr2(1)(k)
Next
Dateiname = lesen & ".xml"
Dateipfad = Ordner & Dateiname
lesen = Text
End Function
soll in der Tabelle die alle Colorthemenfarben anzeigt auch der Colorthemenauswahlname erscheinen, dann folgenden Code benutzen.
Public zeile As Long
Public datname As String
Public datpfad 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
datname = (fi.Name) 'LCase
If Right(datname, 4) = ".xml" Then
Anzahlxml = Anzahlxml + 1
Liste = Liste & Left(fi.Name, Len(fi.Name) - 4) & Chr(13)
datpfad = Ordner & datname
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 z
Dim Text As String
Dim myarr2 As Variant
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)
ReDim myarr2(2)
myarr2(0) = Array("Adjacency", "Alte Farben", "Angles", "Apex", "Apothecary", "Aspect", "Austin" _
, "Black Tie", "Civic", "Clarity", "Composite", "Concourse", "Couture", "Elemental", "Equity", "Essential", "Executive", "Flow", "Foundry", "Grayscale", "Grid", "Hardcover", "Horizon", "Median", "Metro", "Module", "Newsprint", "Opulent", "Oriel", "Origin", "Paper", "Perspective", "Pushpin", "Slipstream", "Solstice", "Standard", "Technic", "Thatch", "Trek", "Urban", "Verve", "Waveform")
myarr2(1) = Array("Nähe", "Alte Farben", "Winkel", "Ananke", "Apotheke", "Ganymed", "Austin", " _
Smoking", "Cronus", "Klarheit", "Zusammengesetzt", "Deimos", "Couture", "Elementar", "Dactylos", "Essenz", "Executive", "Hyperion", "Phoebe", "Graustufe", "Raster", "Hardcover", "Horizont", "Galathea", "Iapetus", "Modul", "Zeitungspapier", "Lysithea", "Nereus", "Okeanos", "Papier", "Perspective", "Pin", "Slipstream", "Nyad", "Larissa", "Haemera", "Stroh", "Metis", "Rhea", "Telesto", "Wellenform")
ActiveWorkbook.Theme.ThemeColorScheme.Load (datpfad)
z = Left(datname, Len(datname) - 4)
For k = LBound(myarr2(0)) To UBound(myarr2(0))
If myarr2(0)(k) = z Then Text = myarr2(1)(k)
Next
With Worksheets(1)
.Cells(zeile, 1).Value = Left(datname, Len(datname) - 4)
.Cells(zeile, 2).Value = Text
.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 = Col(.Cells(zeile, i).Value, .Cells(x, i).Value)
Next
Next
End With
End Sub
@Luc
die xlthemennamen heißen ja (deutsch) Dunkel1,Hell1,Dunkel2,Hell2, wenn jetzt im Farbdialog Dunkel1 und Hell1 getauscht werden, scheint es doch logisch das auch mit Dunkel2 und Hell2 zu machen.
Was die Funktion zur Umwandlung zurück angeht, ist diese schon korrekt, Problem sind nur das Auf- bzw. Abrunden. Hier habe ich die richtige Anwendung noch nicht gefunden.
Gruß Ewald