|
Member
Beiträge: 12
| Servus PhilS,
vielen Dank für Deine Rückmeldung.
Hier mein Code, dieser ist sicher auch noch zu optimieren:
Option Compare Database
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function BedingteFormatierungMehrAls50()
Dim vProgressTitel As String
Dim vZählerP As Long
Dim vAnzahlGesamt As Long
Dim lngSchriftfarbe, lngSchriftfarbe1, lngSchriftfarbe2, lngSchriftfarbe3 As Long
Dim lngIndex As Long
Dim Obj As Object
Dim Frm As Form
Dim ctl As Control
Dim i As Integer
Dim Start As Date
Dim objFormatCondition As FormatCondition
Dim datStart As Date
Dim db As DAO.Database
Dim rst As DAO.Recordset
Set db = CurrentDb
Dim sngStart As Single
Dim sngDauer As Single
On Error GoTo Fehler
sngStart = GetTickCount
lngSchriftfarbe = DLookup("SchriftFarbe", "tbl_Status", "Wert=0")
lngSchriftfarbe1 = DLookup("Schriftfarbe1", "tbl_Optionen")
lngSchriftfarbe2 = DLookup("Schriftfarbe2", "tbl_Optionen")
lngSchriftfarbe3 = DLookup("Schriftfarbe3", "tbl_Optionen")
DoCmd.OpenForm "frmPlan", , , , , acHidden
DoCmd.Hourglass True
Echo False
Form_frmPlan.RecordSource = "tblPlan2"
Set Obj = Forms("frmPlan")
Dim x As Integer
x = 0
For Each ctl In Obj.Section(0).Controls
x = x + 1
Debug.Print x & " " & ctl.Name & " " & Now()
If ctl.ControlType = acTextBox And ctl.Name Like "txtItem*" Then
Do While ctl.FormatConditions.Count > 0
ctl.FormatConditions(0).Delete
Loop
For i = 1 To 4
Set objFormatCondition = ctl.FormatConditions.Add(acFieldValue, acEqual, 1)
Next i
i = 0
Set rst = db.OpenRecordset("SELECT * FROM tbl_Status WHERE Status Not like 'Briefkopf'", dbOpenDynaset, dbSeeChanges)
Do While Not rst.EOF
lngIndex = Mid(ctl.Name, 8)
i = i + 1
Debug.Print x & " " & ctl.Name & " " & Now()
'Sonderstatus
Set objFormatCondition = ctl.FormatConditions.Add(acExpression, , "[" & "Item" & lngIndex & "] = " & rst!Wert & " and [" & "ItemSon" & lngIndex & "] = -1")
With objFormatCondition
.BackColor = DLookup("Farbe", "tbl_Status", "Wert=" & rst!Wert)
.ForeColor = lngSchriftfarbe 'DLookup("SchriftFarbe", "tbl_Status", "Wert=0")
'.FontBold = 0 'DLookup("Fett", "tbl_Status", "Wert=0")
End With
If DLookup("ErweiterteSchriftfarbenVerwenden", "tbl_Optionen") = True Then
' 'Sonderstatus1
Set objFormatCondition = ctl.FormatConditions.Add(acExpression, , "[" & "Item" & lngIndex & "] = " & rst!Wert & " and [" & "ItemSon" & lngIndex & "] = 1")
With objFormatCondition
.BackColor = DLookup("Farbe", "tbl_Status", "Wert=" & rst!Wert)
.ForeColor = lngSchriftfarbe1 'DLookup("Schriftfarbe1", "tbl_Optionen")
'.FontBold = 0 'DLookup("Fett", "tbl_Status", "Wert=0")
End With
' 'Sonderstatus2
Set objFormatCondition = ctl.FormatConditions.Add(acExpression, , "[" & "Item" & lngIndex & "] = " & rst!Wert & " and [" & "ItemSon" & lngIndex & "] = 2")
With objFormatCondition
.BackColor = DLookup("Farbe", "tbl_Status", "Wert=" & rst!Wert)
.ForeColor = lngSchriftfarbe2 'DLookup("Schriftfarbe2", "tbl_Optionen")
'.FontBold = 0 'DLookup("Fett", "tbl_Status", "Wert=0")
End With
'Sonderstatus3
Set objFormatCondition = ctl.FormatConditions.Add(acExpression, , "[" & "Item" & lngIndex & "] = " & rst!Wert & " and [" & "ItemSon" & lngIndex & "] = 3")
With objFormatCondition
.BackColor = DLookup("Farbe", "tbl_Status", "Wert=" & rst!Wert)
.ForeColor = lngSchriftfarbe3 'DLookup("Schriftfarbe3", "tbl_Optionen")
'.FontBold = 0 'DLookup("Fett", "tbl_Status", "Wert=0")
End With
End If
'Normal
Set objFormatCondition = ctl.FormatConditions.Add(acExpression, , "[" & "Item" & lngIndex & "] = " & rst!Wert & " and [" & "ItemSon" & lngIndex & "] = 0")
With objFormatCondition
.BackColor = DLookup("Farbe", "tbl_Status", "Wert=" & rst!Wert)
End With
If i <= 4 Then
ctl.FormatConditions(0).Delete
End If
rst.MoveNext
Loop
End If
Next ctl
rst.Close
Set rst = Nothing
db.Close
Set db = Nothing
' Form_frmPlan.RecordSource = "tblPlan2"
' Form_frmPlan.RecordSource = "tblPlan"
Form_frmPlan.Visible = True
Echo True
DoCmd.Hourglass False
sngDauer = Format(GetTickCount - sngStart, "##,##0")
MsgBox "Dauer: " & Format(sngDauer / 86400000, "hh:mm:ss") & "," & sngDauer Mod 1000
Exit Function
Fehler:
BedingteFormatierungMehrAls50 = False
End Function | |
|
Bedingte Formatierung Performance in accde