UDF für TemeColor-Bestimmung
18.02.2013 15:36:01
Luc:-?
Hallo, Folks;
kann testen wer mag! ;-)
Rem Ermittelt d.Farben d.Stdd-Range-Prop-Objekte (nicht FmtCond-Obj)
' Nur f.xlVss >=12! Kann nicht oW in AddIns bzw Module aufgenommen
' wdn, d.(auch) unter früheren xlVss laufen sollen ->SyntaxFehler!
' Hilfe zu Auslesen OfficeTheme so mies, dass es bislg unmögl war!
' Vs1.2* -LSr -cd:20121010 -fpub: 20130218/herber -lupd:20121122t
Function ThColor(Optional ByVal Bereich As Range, Optional ByVal ObTyp = 1, _
Optional ByVal nurIdx As Boolean)
Dim bix As Integer, cix As Long, rix As Long, xb(), xCol() As Variant, _
xbo As Borders, xBer As Range, xr As Range
On Error GoTo fx
' Application Volatile
If Bereich Is Nothing Then Set Bereich = ActiveWindow.RangeSelection
If Bereich.Count > 1 Then
Set xBer = Bereich
ReDim xCol(xBer.Rows.Count - 1, xBer.Columns.Count - 1)
For Each xr In xBer.Rows
cix = 0
For Each Bereich In xr.Columns
GoSub ew: xCol(rix, cix) = ThColor: cix = cix + 1
Next Bereich
rix = rix + 1
Next xr
ThColor = xCol
Else
ew: With Bereich
Select Case ObTyp
Case 1, "ict", "zft": ObTyp = 1
Case 3, "pct", "mft": ObTyp = 3
Case 6, "fct", "sft": ObTyp = 6
Case 9, "bct", "rft": ObTyp = 9: Set xbo = .Borders
Case 12, "dct", "dft": ObTyp = 12: Set xbo = .Borders
Case Else: Err.Raise xlErrNA
End Select
On Error Resume Next
Select Case ObTyp
Case 1
With .Interior
If IsError(.ThemeColor) Then
GoTo ci
ElseIf CBool(.ThemeColor * .TintAndShade) Then
ThColor = IIf(nurIdx, .ThemeColor & Format(.TintAndShade, _
"+0%;-0%;"), .Color)
Else
ci: If .ColorIndex > 0 Then
ThColor = IIf(nurIdx, .ColorIndex, _
ActiveWorkbook.Colors(.ColorIndex))
Else: ThColor = .ColorIndex
End If
End If
End With
Case 3
With .Interior
If IsError(.ThemeColor) Then
GoTo cp
ElseIf CBool(.PatternThemeColor * .PatternTintAndShade) Then
ThColor = IIf(nurIdx, .PatternThemeColor & Format( _
.PatternTintAndShade, "+0%;-0%;"), .PatternColor)
Else
cp: If .PatternColorIndex > 0 Then
ThColor = IIf(nurIdx, .PatternColorIndex, _
ActiveWorkbook.Colors(.PatternColorIndex))
Else: ThColor = .PatternColorIndex
End If
End If
End With
Case 6
With .Font
If IsError(.ThemeColor) Then
GoTo cx
ElseIf CBool(.ThemeColor * .TintAndShade) Then
ThColor = IIf(nurIdx, .ThemeColor & Format( _
.TintAndShade, "+0%;-0%;"), .Color)
Else
cx: If .ColorIndex > 0 Then
ThColor = IIf(nurIdx, .ColorIndex, _
ActiveWorkbook.Colors(.ColorIndex))
Else: ThColor = .ColorIndex
End If
End If
End With
Case 9, 12
If IsError(xbo.ThemeColor) Then
GoTo ca
ElseIf Not (IsNull(.ThemeColor) Or IsNull(.TintAndShade)) Then
ReDim xb(3)
For bix = 0 To 3
With xbo(bix - CInt(ObTyp = 9) - _
CInt(ObTyp = 12) * (5 + 4 * CInt(bix > 1)))
If IsError(.ThemeColor) Then
If CBool(.TintAndShade) Then
xb(bix) = IIf(nurIdx, .ColorIndex & Format( _
.TintAndShade, "+0%;-0%;"), .Color)
Else: GoTo cb
End If
ElseIf CBool(.ThemeColor * .TintAndShade) Then
xb(bix) = IIf(nurIdx, .ThemeColor & Format( _
.TintAndShade, "+0%;-0%;"), .Color)
Else
cb: If .ColorIndex > 0 Then
xb(bix) = IIf(nurIdx, .ColorIndex, _
ActiveWorkbook.Colors(.ColorIndex))
Else: xb(bix) = .ColorIndex
End If
End If
End With
Next bix
ThColor = xb
Else
With xbo
If CBool(.ThemeColor * .TintAndShade) Then
ThColor = IIf(nurIdx, .ThemeColor & Format( _
.TintAndShade, "+0%;-0%;"), .Color)
Else
ca: With xbo
If .ColorIndex > 0 Then
ThColor = IIf(nurIdx, .ColorIndex, _
ActiveWorkbook.Colors(.ColorIndex))
Else: ThColor = .ColorIndex
End If
End With
End If
End With
End If
End Select
End With
If Not xBer Is Nothing Then Return
End If
GoTo ex
fx: If Err.Number xlErrNA Then
ThColor = "#F" & Err.Number & ": " & Err.Description & "!"
Else: ThColor = CVErr(Err.Number)
End If
ex: Set Bereich = Nothing: Set xBer = Nothing: Set xbo = Nothing
End Function
Viel Spaß!
Gruß Luc :-?