zelarra821
Registered User.
- Local time
- Today, 08:10
- Joined
- Jan 14, 2019
- Messages
- 834
Private Sub btnLimpiar_Click()
Dim i As Integer
For i = 0 To Me.LstPautas.ListCount - 1
Me.LstPautas.Selected(i) = False
Next i
' Do something
End Sub
Private Sub btnSeleccionarTodo_Click()
Dim i As Integer
For i = 0 To Me.LstPautas.ListCount - 1
Me.LstPautas.Selected(i) = True
Next i
' Do something
End Sub
Dim i As Integer
On Error GoTo Err_lbl
Echo False
For i = 0 To Me.LstPautas.ListCount - 1
Me.LstFincas.Selected(i) = True
Next i
Echo True
Err_exit:
Echo True
Exit Sub
Err_lbl:
Echo True
MsgBox Err.Number & ": " & Err.Description, vbInformation, NombreBD
Exit Sub
End Sub
Public Sub AddRemoveSelections(lst As Access.Listbox, JunctionTableName As String, KeySelectField As String, KeyFilterField As String, FilterKeyValue As Long)
Dim FocusedItemIndex As Integer
Dim SelectionID As Long
Dim strSQL As String
If lst.ListIndex > 0 Then
FocusedItemIndex = lst.ListIndex
SelectionID = lst.Column(0, FocusedItemIndex)
'The selected property is an array of all items and holds a true false if the item is selected
If lst.Selected(FocusedItemIndex) Then
'If the item is focused and selected then add it.Add to list
strSQL = "Insert INTO " & JunctionTableName & "(" & KeySelectField & ", " & KeyFilterField & ") VALUES (" & SelectionID & ", " & FilterKeyValue & ")"
' Debug.Print strSql
Else
'If the item is focused but not selected then delete it
strSQL = "DELETE * FROM " & JunctionTableName & " WHERE " & KeySelectField & " = " & SelectionID & " And " & KeyFilterField & " = " & FilterKeyValue
End If
' Debug.Print strSQL
CurrentDb.Execute strSQL
End If
End Sub
Your code failed hereWhen you say "Your add procedure has no error checking", what procedure are you referring to?
I do not understand what that meansBut what code do I have to put now in the button so that it selects me in the form and then adds me to the list box below, and in the delete box?
Public Sub AddRemoveSelections(lst As Access.Listbox, JunctionTableName As String, KeySelectField As String, KeyFilterField As String, FilterKeyValue As Long)
Dim FocusedItemIndex As Integer
Dim SelectionID As Long
Dim strSQL As String
If lst.ListIndex > 0 Then
FocusedItemIndex = lst.ListIndex
SelectionID = lst.Column(0, FocusedItemIndex)
'The selected property is an array of all items and holds a true false if the item is selected
If lst.Selected(FocusedItemIndex) Then
'If the item is focused and selected then add it.Add to list
strSQL = "Insert INTO " & JunctionTableName & "(" & KeySelectField & ", " & KeyFilterField & ") VALUES (" & SelectionID & ", " & FilterKeyValue & ")"
' Debug.Print strSql
Else
'If the item is focused but not selected then delete it
strSQL = "DELETE * FROM " & JunctionTableName & " WHERE " & KeySelectField & " = " & SelectionID & " And " & KeyFilterField & " = " & FilterKeyValue
End If
' Debug.Print strSQL
CurrentDb.Execute strSQL
End If
End Sub
Public Sub AddRemoveSelections(lst As Access.Listbox, JunctionTableName As String, KeySelectField As String, KeyFilterField As String, FilterKeyValue As Long)
Dim FocusedItemIndex As Integer
Dim SelectionID As Long
Dim strSQL As String
Dim i As Integer
For i = 0 To lst.ListCount - 1
FocusedItemIndex = i
'If lst.ListIndex > 0 Then
SelectionID = lst.Column(0, FocusedItemIndex)
'The selected property is an array of all items and holds a true false if the item is selected
If lst.Selected(FocusedItemIndex) = True Then
'If the item is focused and selected then add it.Add to list
strSQL = "Insert INTO " & JunctionTableName & "(" & KeySelectField & ", " & KeyFilterField & ") VALUES (" & SelectionID & ", " & FilterKeyValue & ")"
' Debug.Print strSql
Else
'If the item is focused but not selected then delete it
strSQL = "DELETE * FROM " & JunctionTableName & " WHERE " & KeySelectField & " = " & SelectionID & " And " & KeyFilterField & " = " & FilterKeyValue
End If
Debug.Print strSQL
CurrentDb.Execute strSQL, dbFailOnError
'End If
Next i
End Sub
Private Sub SelectFiltered()
Dim lstFilter As Listbox
Dim lstSelect As Listbox
Dim I As Integer
Dim j As Integer
Dim id As Long
Set lstFilter = Me.LstCriterios
Set lstSelect = Me.LstCriteriosAsignados
For I = 0 To lstFilter.ListCount - 1
id = lstFilter.ItemData(I)
For j = 0 To lstSelect.ListCount - 1
If lstSelect.ItemData(j) = id Then lstSelect.Selected(j) = True
Next j
Next I
End Sub
Private Sub SelectFiltered()
Dim lstFilter As Listbox
Dim lstSelect As Listbox
Dim I As Integer
Dim j As Integer
Dim ID As Long
Set lstFilter = Me.LstCriterios
Set lstSelect = Me.LstCriteriosAsignados
On Error GoTo Err_lbl
Echo False
For I = 0 To lstFilter.ListCount - 1
ID = lstFilter.ItemData(I)
For j = 0 To lstSelect.ListCount - 1
If lstSelect.ItemData(j) = ID Then lstFilter.Selected(I) = True
Next j
Next I
Echo True
Err_exit:
Echo True
Exit Sub
Err_lbl:
Echo True
MsgBox Err.Number & ": " & Err.Description, vbInformation, NombreBD
Exit Sub
End Sub
Private Sub CmdVerInforme_Click()
Dim strFilter As String
Dim strArgumento As String
If Not IsNull(Me.txtDesdeF) And Not IsNull(Me.txtHastaF) Then
strFilter = GetBetweenFilter(Me.txtDesdeF, Me.txtHastaF, "Fecha")
strArgumento = "Balance del " & Format(Me.txtDesdeF, "dd-mm-yy") & " hasta el " & _
Format(Me.txtHastaF, "dd-mm-yy")
Else
MsgBox "Es necesario introducir las dos fechas.", vbInformation, NombreBD
Exit Sub
End If
If CriteriosAsignados.Count > 0 Then
strFilter = GetCriteria(Me.LstCriterios, "IdSubtipo")
End If
If FincasAsignadas.Count > 0 Then
strFilter = strFilter & " And " & GetCriteria(Me.LstFincas, "IdFinca")
End If
DoCmd.OpenReport "IBalance", acViewPreview, , strFilter, , strArgumento
DoCmd.Close acForm, "FDialogoBalance", acSaveYes
End Sub
If CriteriosAsignados.Count > 0 Then
strFilter = GetCriteria(Me.LstCriterios, "IdSubtipo")
End If
Dim strFilter As String
Dim strArgumento As String
If Not IsNull(Me.txtDesdeF) And Not IsNull(Me.txtHastaF) Then
strFilter = GetBetweenFilter(Me.txtDesdeF, Me.txtHastaF, "Fecha")
Debug.Print "Between Filter " & strFilter
strArgumento = "Balance del " & Format(Me.txtDesdeF, "dd-mm-yy") & " hasta el " & _
Format(Me.txtHastaF, "dd-mm-yy")
Else
MsgBox "Es necesario introducir las dos fechas.", vbInformation, NombreBD
Exit Sub
End If
If CriteriosAsignados.Count > 0 Then
strFilter = GetCriteria(Me.LstCriterios, "IdSubtipo")
Debug.Print "Criterios " & strFilter
End If
If FincasAsignadas.Count > 0 Then
strFilter = strFilter & " And " & GetCriteria(Me.LstFincas, "IdFinca")
Debug.Print "Fincase " & strFilter
End If
DoCmd.OpenReport "IBalance", acViewPreview, , strFilter, , strArgumento
DoCmd.Close acForm, "FDialogoBalance", acSaveYes
End Sub
Between Filter Fecha BETWEEN #02/01/2023# AND #02/22/2024#
Criterios IdSubtipo = 30005 OR IdSubtipo = 40004 OR IdSubtipo = 30009 OR IdSubtipo = 30016
Fincase IdSubtipo = 30005 OR IdSubtipo = 40004 OR IdSubtipo = 30009 OR IdSubtipo = 30016 And IdFinca = 5 OR IdFinca = 8 OR IdFinca = 7
Private Sub CmdVerInforme_Click()
Dim strFilter As String
If Not IsNull(Me.txtDesdeF) And Not IsNull(Me.txtHastaF) Then
strFilter = GetBetweenFilter(Me.txtDesdeF, Me.txtHastaF, "Fecha")
Else
MsgBox "Es necesario introducir las dos fechas.", vbInformation
Exit Sub
End If
If CriteriosAsignados.Count > 0 Then
strFilter = strFilter & " AND " & GetCriteria(Me.LstCriterios, "IdSubtipo")
End If
If FincasAsignadas.Count > 0 Then
If strFilter = "" Then
strFilter = GetCriteria(Me.LstFincas, "IdFinca")
Else
strFilter = strFilter & " AND " & GetCriteria(Me.LstFincas, "IdFinca")
End If
End If
Debug.Print strFilter
End Sub
Private Function GetCriteria(Listbox As Listbox, Criterio As String) As String
Dim stDocCriteria As String
Dim VarItm As Variant
For Each VarItm In Listbox.ItemsSelected
stDocCriteria = stDocCriteria & Criterio & " = " & Listbox.Column(0, VarItm) & " OR "
Next
If stDocCriteria <> "" Then
stDocCriteria = Left(stDocCriteria, Len(stDocCriteria) - 4)
Else
stDocCriteria = "True"
End If
GetCriteria = stDocCriteria
End Function
Private Sub CmdVerInforme_Click()
Dim CriteriaFilter As String
Dim FincaFilter As String
Dim strFilter As String
If Not IsNull(Me.txtDesdeF) And Not IsNull(Me.txtHastaF) Then
strFilter = GetBetweenFilter(Me.txtDesdeF, Me.txtHastaF, "Fecha")
Else
MsgBox "Es necesario introducir las dos fechas.", vbInformation
Exit Sub
End If
CriteriaFilter = GetCriteria(Me.LstCriterios, "IdSubtipo")
If CriteriaFilter <> "True" Then
CriteriaFilter = "(" & CriteriaFilter & ")"
strFilter = strFilter & " AND " & CriteriaFilter
End If
FincaFilter = GetCriteria(Me.LstFincas, "IdFinca")
If FincaFilter <> "True" Then
If strFilter <> "" Then
FincaFilter = "(" & FincaFilter & ")"
strFilter = strFilter & " AND " & FincaFilter
Else
strFilter = FincaFilter
End If
End If
Debug.Print strFilter
Fecha BETWEEN #02/01/2024# AND #02/29/2024# AND (IdSubtipo = 40002 OR IdSubtipo = 40004) AND (IdFinca = 6 OR IdFinca = 5)
Fecha BETWEEN #02/01/2024# AND #02/29/2024# AND (IdFinca = 6 OR IdFinca = 5)
Fecha BETWEEN #02/01/2024# AND #02/29/2024# AND (IdSubtipo = 30018 OR IdSubtipo = 20011)
Fecha BETWEEN #02/01/2024# AND #02/29/2024#