…pgmiert, Reinhard,
das deine CellFormat-Intention aufgreift… ;-)
Daran kannst du wohl erkennen, dass diese Bezeichnung wohl doch keine so gute Idee wäre, denn da gehört ja noch viel mehr dazu als nur ein NumberFormat; ggf wäre dann DataFormat angebracht, aber sei's drum…
Jedenfalls habe ich die udF vorhin mal unter Xl12 eingesetzt und dabei festgestellt, dass die MS-Jungs nicht nur die BedingtFormatierung verändert haben. Auch die normale Formatierung kann man stellenweise nicht mehr wie gewohnt abfragen! Hatte man früher verschiedenfarbige Rahmen um eine Zelle, war das daran zu erkennen, dass NULL zurückgegeben wurde. Jetzt ist es 0 für .Borders.Color und xlNone=-4142 für .Borders.ColorIndex, genauso wie bei fehlenden Rahmen. Toll! Muss man also auf jeden Fall alles einzeln abfragen, da möglicherweise auch .Borders.Linestyle nicht weiterhilft wie früher. Jedenfalls reagiert die udF unter Xl12 anders als unter Xl9! Aber sieh' selbst…
Rem Ermittelt regul-unbedingt LokalZellFormat (RgObjekt o.Berücks v.NbFmtFrbb)
' Vs1.1 -LSr -cd:20120403 -1pub: 20120404 herber -lupd:20120404t ->unfertig!
Function CFormat(Optional ByVal Zelle As Range, Optional ByVal ZFmTyp, _
Optional ByVal TrennZ)
Const dzTrO$ = ".", kzMult$ = "µ", kzNull$ = "", mxKlO$ = "{?}", _
mxTrO$ = ",;", txStrO$ = " StrTh", txStrL$ = " DuStr", _
srTrZ$ = " " 'ZCodes: 32/160
Dim ix As Integer, tix As Integer, fmCCI$, dzTrL$, liTrL$, mxKlL$, mxTrL$, _
cf, tmFmt As Variant, ac As Range
On Error GoTo fx
CFormat = CVErr(xlErrNull)
With Application
If IsError(.Caller) Then
ElseIf TypeName(.Caller) = "Range" Then
Set ac = .Caller
If Zelle Is Nothing Then Set Zelle = ac
ElseIf Zelle Is Nothing Then
Err.Raise xlErrRef
End If
dzTrL = .International(xlDecimalSeparator)
liTrL = .International(xlListSeparator)
mxKlL = .International(xlLeftBrace) & "?" & .International(xlRightBrace)
mxTrL = .International(xlColumnSeparator) & .International(xlRowSeparator)
End With
If IsMissing(ZFmTyp) Then ZFmTyp = 0
If Not IsNumeric(ZFmTyp) Then ZFmTyp = Left(LCase(ZFmTyp), 3): fmCCI = ZFmTyp
Select Case ZFmTyp
Case 0, "for", "fmt", "zfo", "nfo", "zaf", "nbf", "nuf"
If Left(ZFmTyp, 1) = "n" Then CFormat = Zelle.NumberFormat Else _
CFormat = Zelle.NumberFormatLocal
ZFmTyp = 0.1
Case 1, "hgf", "bgc", "zfa", "ico", 1.1, "zfx", "icx", 1.2, "zfh", "ich", _
1.3, "zfw", "icw", 1.4, "zfn", "icn"
CFormat = Zelle.Interior.ColorIndex
If Not IsNumeric(ZFmTyp) Then _
ZFmTyp = 1 + InStr("xhwn", Right(ZFmTyp, 1)) / 10
Case 2, "vgm", "fgp", "mus", "pat", "zmu", "cpa"
CFormat = Zelle.Interior.Pattern: ZFmTyp = 2.1
Case 3, "vgf", "fgc", "mfa", "pco", 3.1, "mfx", "pcx", 3.2, "mfh", "pch", _
3.3, "mfw", "pcw", 3.4, "mfn", "pcn"
CFormat = Zelle.Interior.PatternColorIndex
If Not IsNumeric(ZFmTyp) Then _
ZFmTyp = 3 + InStr("hx", Right(ZFmTyp, 1)) / 10
Case 4, "txa", "txt", 4.5, "ssn", "fst", 4.6, "sgr", "fsi", _
4.7, "sch", "sft", "fon", "fnt"
For ix = 5 To 7
Select Case ZFmTyp
Case 4, "txa", "txt"
If IsEmpty(tmFmt) Then ReDim tmFmt(2)
On ix - 4 GoTo x1, x2, x3
Case 4.5, "ssn", "fst"
If ix = 5 Then
x1: If IsNull(Zelle.Font.FontStyle) Then 'noch ausbauen!
CFormat = kzMult
ElseIf ZFmTyp = "txt" Or Left(ZFmTyp, 1) = "f" Then
CFormat = Replace(Replace(Replace(Zelle.Font.FontStyle, _
"Standard", "Normal"), "Fett", "Bold"), _
"Kursiv", "Italic")
Else: CFormat = Replace(Replace(Zelle.Font.FontStyle, _
"Bold", "Fett"), "Italic", "Kursiv")
End If
If IsEmpty(tmFmt) Then Exit For Else tmFmt(ix - 5) = CFormat
End If
Case 4.6, "sgr", "fsi"
If ix = 6 Then
x2: If IsNull(Zelle.Font.Size) Then 'noch ausbauen!
CFormat = kzMult
Else: CFormat = Zelle.Font.Size
End If
If IsEmpty(tmFmt) Then Exit For Else tmFmt(ix - 5) = CFormat
End If
Case 4.7, "sch", "sft", "fon", "fnt"
If ix = 7 Then
x3: If IsNull(Zelle.Font.Name) Then 'noch ausbauen!
CFormat = kzMult
Else: CFormat = Zelle.Font.Name
End If
If IsEmpty(tmFmt) Then Exit For Else tmFmt(ix - 5) = CFormat
End If
End Select
Next ix
ZFmTyp = 4.1
Case 5, "txs", "txl", 5.8, "unt", "und", "ust", "uli", _
5.9, "dur", "str", "dst", "stt", "sth"
For ix = 8 To 9 '¿wo sub/sup untbringen? Fehlt in actCellForm!
Select Case ZFmTyp
Case 5, "txs", "txl"
If IsEmpty(tmFmt) Then ReDim tmFmt(1)
On ix - 7 GoTo x4, x5
Case 5.8, "unt", "und", "ust", "uli"
If ix = 8 Then
x4: If IsNull(Zelle.Font.Underline) Then 'noch ausbauen!
CFormat = kzMult
ElseIf Zelle.Font.Underline = xlNone Then
CFormat = kzNull
Else: CFormat = Zelle.Font.Underline
End If
If IsEmpty(tmFmt) Then Exit For Else tmFmt(ix - 8) = CFormat
End If
Case 5.9, "dur", "str", "dst", "stt", "sth"
If ix = 9 Then
x5: If IsNull(Zelle.Font.Strikethrough) Then 'noch ausbauen!
CFormat = kzMult
ElseIf ZFmTyp = "txl" Or Left(ZFmTyp, 1) = "s" Then
CFormat = Split(txStrO)(Abs(Zelle.Font.Strikethrough))
Else: CFormat = Split(txStrL)(Abs(Zelle.Font.Strikethrough))
End If
If IsEmpty(tmFmt) Then Exit For Else tmFmt(ix - 8) = CFormat
End If
End Select
Next ix
ZFmTyp = 5.1
Case 6, "txf", "txc", "sfa", "fco", 6.1, "sfx", "fcx", 6.2, "sfh", "fch", _
6.3, "sfw", "fcw", 6.4, "sfn", "fcn"
If IsNull(Zelle.Font.ColorIndex) Then 'noch ausbauen!
CFormat = kzMult: ZFmTyp = 6.1
Else: CFormat = Zelle.Font.ColorIndex
If Not IsNumeric(ZFmTyp) Then _
ZFmTyp = 6 + InStr("xhwn", Right(ZFmTyp, 1)) / 10
End If
Case 7, "rad", "bow", "rst", "bwt"
With Zelle.Borders
If IsNull(.Weight) And _
(IsNull(.LineStyle) Or .LineStyle xlLineStyleNone) Then
ReDim tmFmt(xlEdgeRight - xlEdgeLeft) 'BedFmtKonst xlLineStyleNone Then
CFormat = .Item(ix).Weight: ZFmTyp = 7.1
GoSub ew: tmFmt(ix - xlEdgeLeft) = CFormat
ElseIf IsMissing(TrennZ) Then
tmFmt(ix - xlEdgeLeft) = ""
ElseIf IsError(TrennZ) Or CBool(InStr(srTrZ, TrennZ)) Then
tmFmt(ix - xlEdgeLeft) = kzNull
End If
Next ix
ElseIf .LineStyle = xlLineStyleNone Then
CFormat = Null: ZFmTyp = 7.5
Else: CFormat = .Weight: ZFmTyp = 7.1
End If
End With
Case 8, "ral", "bol", "rli", "bli"
With Zelle.Borders
If IsNull(.LineStyle) Then
ReDim tmFmt(xlEdgeRight - xlEdgeLeft)
For ix = xlEdgeLeft To xlEdgeRight
If .Item(ix).LineStyle xlLineStyleNone Then
CFormat = .Item(ix).LineStyle: ZFmTyp = 8.1
GoSub ew: tmFmt(ix - xlEdgeLeft) = CFormat
ElseIf IsMissing(TrennZ) Then
tmFmt(ix - xlEdgeLeft) = ""
ElseIf IsError(TrennZ) Or CBool(InStr(srTrZ, TrennZ)) Then
tmFmt(ix - xlEdgeLeft) = kzNull
End If
Next ix
ElseIf .LineStyle = xlLineStyleNone Then
CFormat = Null: ZFmTyp = 8.5
Else: CFormat = .LineStyle: ZFmTyp = 8.1
End If
End With
Case 9, "raf", "boc", "rfa", "bco", 9.1, "rfx", "bcx", 9.2, "rfh", "bch", _
9.3, "rfw", "bcw", 9.4, "rfn", "bcn"
With Zelle.Borders
If Not IsNumeric(ZFmTyp) Then _
ZFmTyp = 9 + InStr("xhwn", Right(ZFmTyp, 1)) / 10
If IsNull(.ColorIndex) And _
(IsNull(.LineStyle) Or .LineStyle xlLineStyleNone) Then
ReDim tmFmt(xlEdgeRight - xlEdgeLeft)
For ix = xlEdgeLeft To xlEdgeRight
If .Item(ix).LineStyle xlLineStyleNone Then
CFormat = .Item(ix).ColorIndex
GoSub ew: tmFmt(ix - xlEdgeLeft) = CFormat
ElseIf IsMissing(TrennZ) Then
tmFmt(ix - xlEdgeLeft) = ""
ElseIf IsError(TrennZ) Or CBool(InStr(srTrZ, TrennZ)) Then
tmFmt(ix - xlEdgeLeft) = kzNull
End If
Next ix
ElseIf IsNull(.ColorIndex) Or .LineStyle = xlLineStyleNone Then
CFormat = Null: ZFmTyp = ZFmTyp + 0.5
Else: CFormat = .ColorIndex
End If
End With
Case 10 - 12 'Reserve f.Diagonalrahmen
Err.Raise xlErrNA
Case Is >= 13 'evtl Reserve f.Cell/TextProps wie Ausrichtung u.a.
Err.Raise xlErrNA
End Select
If Not IsEmpty(tmFmt) Then
If IsMissing(TrennZ) Then
CFormat = tmFmt
Else
If IsError(TrennZ) Then
CFormat = Join(tmFmt)
ElseIf TrennZ = "" Then
CFormat = Join(tmFmt, liTrL)
ElseIf TrennZ Like mxKlL Then
For tix = 1 To 2
If TrennZ = Replace(mxKlL, "?", _
Mid(mxTrL, tix, 1)) Then Exit For
Next tix
If tix mxKlO Then
CFormat = Join(tmFmt, TrennZ)
Else: GoTo mo
End If
ElseIf TrennZ Like mxKlO Then
mo: For tix = 1 To 2
If TrennZ = Replace(mxKlO, "?", _
Mid(mxTrO, tix, 1)) Then Exit For
Next tix
If tix dzTrO Then
CFormat = CFormat & IIf(ix = LBound(tmFmt), _
"", Mid(mxTrO, tix, 1)) & _
Replace(CStr(tmFmt(ix)), dzTrL, dzTrO)
Else: CFormat = CFormat & IIf(ix = LBound(tmFmt), "", _
Mid(mxTrO, tix, 1)) & CStr(tmFmt(ix))
End If
Next ix
CFormat = CFormat & Right(mxKlO, 1)
Else: CFormat = Join(tmFmt, TrennZ)
End If
Else: CFormat = Join(tmFmt, TrennZ)
End If
If ZFmTyp * 10 Mod 10 >= 5 Then CFormat = "[" & _
Replace(Replace(CFormat, "[", ""), "]", "") & "]"
End If
Else
ew: If CBool(ZFmTyp * 10 Mod 5 - 1) Then
If Not IsNull(CFormat) Then
If Int(ZFmTyp) = 1 Or _
(Int(ZFmTyp) > 0 And Int(ZFmTyp) Mod 3 = 0) Then
If CFormat > 0 Then
CFormat = ActiveWorkbook.Colors(CFormat)
ElseIf CFormat = xlAutomatic Then
CFormat = ActiveWorkbook.Colors(1 - _
CInt(Int(ZFmTyp) = 1))
ElseIf CFormat = xlNone Or CFormat = 0 Then
CFormat = "": GoTo ez
End If
End If
Select Case ZFmTyp * 10 Mod 5
Case 2: CFormat = "&h" & Hex(CFormat)
Case 3: CFormat = Right("000000" & Hex(CFormat), 6)
If ac.HasArray Then
cf = Evaluate("T2CharVect(""" & CFormat & """,3)")
If IsError(cf) Then GoTo ec
CFormat = "#" & cf(UBound(cf)) & cf(LBound(cf) + 1) & _
cf(LBound(cf))
Else
ec: If Left(CFormat, 2) Right(CFormat, 2) Then
CFormat = "#" & Right(CFormat, 2) & _
Mid(CFormat, 3, 2) & Left(CFormat, 2)
Else: CFormat = "#" & CFormat
End If
End If
Case 4
If fmCCI "" Then
CFormat = Evaluate("CellContIn(" & Zelle.Address & _
",,,""" & fmCCI & """)")
Else: CFormat = CVErr(xlErrNA)
End If
End Select
End If
End If
ez: If ZFmTyp * 10 Mod 10 >= 5 Then CFormat = "[" & CFormat & "]"
If Not IsEmpty(tmFmt) Then Return
End If
GoTo ex
fx: If Err.Number >= xlErrNull And Err.Number
Ist zwar recht lang geraten (so etwas publiziere ich eigentl nur ungern in Foren!), aber enthält längst nicht alles, was auslesbar ist. Aber das kannst du ja dann noch ergänzen. ;-)
Wdn zwar auch ein paar udFktt angesprochen, die dein Xl nicht kennt, aber da das über Evaluate läuft, sollte es nicht schaden und nur marginale Fktionalitätsverluste mit sich bringen. Außerdem kann es sein, dass dein Xl der Meinung ist, hier läge ein Zirkelbezug vor, was an der Range-Variablen ac liegen wird. Musst du dann halt Iterationen zulassen!
Viel Spaß! Gruß und FrOst, Luc :-?
