Bedingte Formatierung Performance in accde
103021
Gesendet: 15.11.16 17:24
Betreff: RE: Bedingte Formatierung Performance in accde


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
Top of the page Bottom of the page