AW: DoEvents - ohne punkt natürlich e.o.m.
27.03.2016 20:03:57
Mullit
Hallo,
zu 1): den Code in die aufgeführten Module:
' **********************************************************************
' Modul: uFor Typ: Userform
' **********************************************************************
Option Explicit
' die folgenden Makros werden benötigt, um die Listbox einzufärben * 24.03.16 Mullit
Private mblnNoChangeEvent As Boolean
Private mblnBox1Init As Boolean
Private Sub che1_Click()
Call prcSetBoxColorByChkBox(probjListBox:=lBo1, _
probjCheckBox:=che1, pvlngBoxColor:=BOX1_COLOR)
End Sub
Private Sub che2_Click()
Call prcSetBoxColorByChkBox(probjListBox:=lBo2, _
probjCheckBox:=che2, pvlngBoxColor:=BOX2_COLOR)
End Sub
Private Sub che3_Click()
Call prcSetBoxColorByChkBox(probjListBox:=lBo3, _
probjCheckBox:=che3, pvlngBoxColor:=BOX3_COLOR)
End Sub
Private Sub lBo1_Change()
If Not mblnNoChangeEvent Then Call prcStartTimer(probjListBox:=lBo1)
Call SU_ListBox_Alle_Keine_Prüfen(probjListBox:=lBo1, _
probjCheckBox:=che1, pvlngVon:=0)
End Sub
Private Sub lBo2_Change()
If Not mblnNoChangeEvent Then Call prcStartTimer(probjListBox:=lBo2)
Call SU_ListBox_Alle_Keine_Prüfen(probjListBox:=lBo2, _
probjCheckBox:=che2, pvlngVon:=0)
End Sub
Private Sub lBo3_Change()
If Not mblnNoChangeEvent Then Call prcStartTimer(probjListBox:=lBo3)
Call SU_ListBox_Alle_Keine_Prüfen(probjListBox:=lBo3, _
probjCheckBox:=che3, pvlngVon:=0)
End Sub
Private Sub UserForm_Activate()
mblnBox1Init = True
lBo1.BackColor = BOX1_COLOR
lBo2.BackColor = BOX2_COLOR
lBo3.BackColor = BOX3_COLOR
End Sub
Friend Property Let prpblnNoChangeEvent(ByVal pvblnNoChangeEvent As Boolean)
Let mblnNoChangeEvent = pvblnNoChangeEvent
End Property
Friend Property Get prpblnBox1Init() As Boolean
Let prpblnBox1Init = mblnBox1Init
End Property
Friend Property Let prpblnBox1Init(ByVal pvblnBox1Init As Boolean)
Let mblnBox1Init = pvblnBox1Init
End Property
Private Sub prcSetBoxColorByChkBox(ByRef probjListBox As MSForms.ListBox, _
ByRef probjCheckBox As MSForms.CheckBox, ByVal pvlngBoxColor As Long)
Dim lngIndex As Long
With probjListBox
.BackColor = IIf(probjCheckBox.Value, RESET_COLOR, pvlngBoxColor)
For lngIndex = 0 To .ListCount - 1
.Selected(pvargIndex:=lngIndex) = probjCheckBox.Value
Next
End With
End Sub
' **********************************************************************
' Modul: c_lBo_färben Typ: Standardmodul
' **********************************************************************
Option Explicit
Option Private Module
'diese Makros werden benötigt, um die Listbox einzufärben - 24.03.16 Herber Mullit
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Public Const BOX1_COLOR As Long = vbGreen
Public Const BOX2_COLOR As Long = &HFF00FF 'pink vbRed
Public Const BOX3_COLOR As Long = vbRed
Public Const RESET_COLOR As Long = vbWhite
Private lobjListBox As MSForms.ListBox
Public Sub prcStartTimer(ByRef probjListBox As MSForms.ListBox)
Set lobjListBox = probjListBox
Call SetTimer(Application.hwnd, 0&, 200&, AddressOf TimerProc)
End Sub
Private Sub prcStopTimer()
Call KillTimer(Application.hwnd, 0&)
End Sub
Private Sub TimerProc(ByVal pvlngHwnd As Long, ByVal pvlngnIDEvent As Long, _
ByVal pvlnguElapse As Long, ByVal pvlnglpTimerFunc As Long)
Call prcStopTimer
Call prcSetBoxColor
End Sub
Private Sub prcSetBoxColor() 'Hauptprogramm, hier müssen die einzelnen "lBo" aufgelistet sein
Dim lngListIndex As Long, lngTopIndex As Long
With lobjListBox
lngListIndex = .ListIndex
lngTopIndex = .TopIndex
If .Selected(pvargIndex:=.ListIndex) Then
If .BackColor <> RESET_COLOR Then
uFor.prpblnNoChangeEvent = True
.BackColor = RESET_COLOR
.ListIndex = lngListIndex
.Selected(pvargIndex:=lngListIndex) = True
.TopIndex = lngTopIndex
uFor.prpblnNoChangeEvent = False
End If
Else
With uFor
If lobjListBox Is .lBo2 Then
Call prcSetBoxToColor(pvlngListIndex:=lngListIndex, _
pvlngTopIndex:=lngTopIndex)
ElseIf Not .prpblnBox1Init Then
Call prcSetBoxToColor(pvlngListIndex:=lngListIndex, _
pvlngTopIndex:=lngTopIndex)
Else
.prpblnBox1Init = Not .prpblnBox1Init
End If
End With
End If
End With
Set lobjListBox = Nothing
End Sub
Private Sub prcSetBoxToColor(ByVal pvlngListIndex As Long, _
ByVal pvlngTopIndex As Long)
Dim ialngIndex As Long
With lobjListBox
For ialngIndex = 1 To .ListCount
If .Selected(pvargIndex:=ialngIndex - 1) Then Exit For
Next
If ialngIndex = .ListCount + 1 Then
Select Case lobjListBox.Name
Case Is = "lBo1": .BackColor = BOX1_COLOR
Case Is = "lBo2": .BackColor = BOX2_COLOR
Case Else: .BackColor = BOX3_COLOR
End Select
.ListIndex = pvlngListIndex
.TopIndex = pvlngTopIndex
End If
End With
End Sub
' **********************************************************************
' Modul: Makros Typ: Standardmodul
' **********************************************************************
Option Explicit
Public Sub SU_ListBox_Alle_Keine_Prüfen(ByRef probjListBox As MSForms.ListBox, _
ByRef probjCheckBox As MSForms.CheckBox, ByVal pvlngVon As Long)
Dim lngAnz As Long, lngIndex As Long, lngCount As Long
lngAnz = probjListBox.ListCount - 1
If lngAnz < pvlngVon Then Exit Sub
For lngIndex = pvlngVon To lngAnz
If probjListBox.Selected(pvargIndex:=lngIndex) Then lngCount = lngCount + 1
Next
If lngCount = lngAnz + 1 Then
probjCheckBox.Value = True
ElseIf lngCount = 0 Then
probjCheckBox.Value = False
End If
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
zur Frage: hab ich befürchtet, daß Die Frage kommt, die Abfrage dient dazu, den Fall abzufangen, wenn die Listbox bei Erstauswahl keinen Wert selektiert, das kann man allerdings auch verhindern, indem man den Code nacheditiert und könnte dann u.U. auch raus...
Gruß, Mullit