Access-o-Mania

Hallo Gemeinde,
heute habe ich meine Spendierhosen an...

Oft ist es doch so, dass man einen Datensatz suchen will, man kennt ungefähr ein paar Suchkriterien.
Man kann das mit einem UFo realisieren und im Kopf des Formulars Suchfelder anbieten.
Leider sind UFos nicht in der Lage, Datensätze unter- UND nebeneinander oder auch nur nebeneinander darzustellen und so wenig ergonomisch.
Mit ein wenig Fleiß und relativ wenig VBA-Code geht's auch anders. Für eine kleine, private Video-Verwaltung möchte ich z. B. nach Schauspielern suchen und habe dafür folgendes Formular entworfen:

2021-04-16 22_13_15-Access - pdb _ Datenbank- D___pdb_pdb.accdb (Access 2007 - 2016-Dateiformat).jpg

Ja - das sieht recht komplex aus, ist aber nicht so schwierig.
Es funktioniert so:
Im Formularkopf (dunkelgelb) können Suchkriterien definiert werden. Bei Feldern, hinter denen sich ein Select-Button befindet, können via Auswahl-Fenster jeweils mehrere Tags ausgewählt werden. Deren interne Referenzen werden in den grünen Feldern zur späteren Verwendung gespeichert (unsichtbar).

Nach Klicken des Lupe-Buttons wird ein SQL-String für die Suche gebastelt und ein Recordset ReadOnly geöffnet (im Code einfach Mal auf 200 Records begrenzt); finden sich mehr als 200 Records, erfolgt eine entspr. Warnung, ebenso wenn nichts gefunden wird.

Der Recordset wird eingelesen und nur die relevanten Felder (Name, Bild und interner Schlüssel) werden in entspr. Arrays kopiert.
Danach werden die ersten 20 Records angezeigt, der User kann zu anderen Seiten blättern (falls mehr als 20 Records gefunden werden).
Zur Darstellung der Funde dienen (hier) 20 Blöcke mit je 3 Feldern:
Name "NameX", Bild "BildX" und darüber gelegt ein transparenter Button "ButtonX" mit X = 1 bis 20. Im OnClick-Event der Buttons steht "=ButtonGeklickt(X)".
Um das Formular aufzubauen, habe ich einen solchen Block einmal definiert, dann als Zeile 5mal dupliziert und die Zeilen schließlich 4mal eingefügt. Dann noch die Namen angepasst und den Aufruf in den Buttons. Ist halt etwas Fleißarbeit...

In der Funktion "ButtonGeklickt(intButton as integer)" passiert zur Laufzeit alles andere. Es wird ein Popup-Dialog aufgerufen, der den Schauspieler komplett mit Namen und weiteren Daten sowie einem größeren Bild darstellt. Dieser Dialog hat Buttons "Übernehmen" und "Abbruch". Wird "Übernehmen" geklickt, wird der Rand des aufrufenden Buttons etwas dicker und rot dargestellt (ansonsten Haarlinie und schwarz). Die erfolgte Selektion merke ich mir in einem 200er-Boolean-Array.

Beim Wechsel zu einer anderen Seite werden andere (bis zu 20) Records dargestellt und ggf. rot umrandet, weil sie schon selektiert wurden. Der Code hinter "Nächste Seite" z. B. lautet sehr simpel:
Private Sub btnNext_Click()
    Call CheckPage(txtPageNo + 1)
End Sub
"CheckPage" macht den Rest, z. B. Start-Position der 200er-Arrays setzen, (bis zu) 20 Datensätze anzeigen (bzw. die restlichen Boxen leeren. Alles sehr simpel gestrickt.

Wer Interesse an dieser Lösung hat, kann ja schreiben und ich stelle kostenlos eine abgespeckte DB zur Verfügung. Das mache ich aber erst, wenn tatsächlich Interesse besteht... lol.

Gruß,
crystal

Moin,

ich bin grundsätzlich interessiert. Weniger um die Nutzung der DB, sondern eher an die Art der Umsetzung.

Frei nach dem Motto, man muss das Rad ja nicht neu erfinden, könnte ich ggf. was für mich übernehmen.

🤗

@Xoar
Hallo!
Hier einfach mal die Code-Sequenzen.

Aufruf des Such-Formulars im Movie-Formular:
Private Sub btnSearchActor_Click()
Dim i As Integer
Dim strActorsToAdd() As String
Dim strSQL As String

    DoCmd.OpenForm "modalSearchActors", acNormal, , , , acDialog
    If g_bCancel Then Exit Sub
    strActorsToAdd = Split(g_sActorsSelected, ",")
    For i = LBound(strActorsToAdd) To UBound(strActorsToAdd)
        If strActorsToAdd(i) <> "" Then
            strSQL = "INSERT INTO [MovieActors]([MovieActorMovieRef], [MovieActorActorRef]) VALUES (" & _
                g_lMovieId & ", " & strActorsToAdd(i) & ");"
            'Debug.Print strSQL
            CurrentDb.Execute strSQL, 128
        End If
    Next
    Me.subMovieActors.Form.Requery
   
End Sub

Anmerkungen: Variable, deren Name mit "g_" beginnt, sind global, also in einem Modul definiert.

Im Movie-Formular gibt's ein Ufo, in dem die Darsteller des Films angezeigt werden. Ich fülle einfach die zugrunde liegende Tabelle MovieActors per SQL mit den im Such-Formular gewählten Darstellern, die als "Nr1,Nr2,Nr3," in einem globalen String stehen....

Und hier der komplette Code des Such-Formulars.
Der Einfachheit halber habe ich im Formularkopf alle Felder außer Name entfernt (s. Bild im ersten Post).
Option Compare Database
Option Explicit

Dim lngActorId(1 To 200) As Long
Dim strActorName(1 To 200) As String
Dim strFileName(1 To 200) As String
Dim blnActorSelected(1 To 200) As Boolean
Dim intActorsMax As Integer

Public Function TriggerButton(intButton As Integer)
Dim i As Integer

    i = (txtPageNo - 1) * 20 + intButton
   
    If Me.Controls("btnDummy" & intButton).BorderColor = vbRed Then
        Me.Controls("btnDummy" & intButton).BorderColor = vbBlack
        Me.Controls("btnDummy" & intButton).BorderWidth = 1
        blnActorSelected(i) = False
        txtSelected = txtSelected - 1
    Else
'vvv uncomment to use modal actor form
'        DoCmd.OpenForm "Actors", acNormal, , , , acDialog, "Actor=" & lngActorId(i)
'        If g_bActorSelected Then
            Me.Controls("btnDummy" & intButton).BorderColor = vbRed
            Me.Controls("btnDummy" & intButton).BorderWidth = 3
            blnActorSelected(i) = True
            txtSelected = txtSelected + 1
'        End If
    End If
    Call Check_txtSelected
   
End Function

Public Function TriggerBox(intBox As Integer, blnVisible As Boolean)
   
    Me.Controls("txtActor" & intBox).Visible = blnVisible
    Me.Controls("PicMain" & intBox).Visible = blnVisible
    Me.Controls("btnDummy" & intBox).Visible = blnVisible
   
End Function

Private Sub btnDelFilter_Click()
Dim i As Integer
   
    txtName = ""
   
    cboOrder = ""
   
    txtCount.Visible = False
    txtPageNo.Visible = False
    txtPageMax.Visible = False
    txtSelected.Visible = False
    btnRetFound.Visible = False
   
    btnFirst.Visible = False
    btnNext.Visible = False
    btnPrevious.Visible = False
    btnLast.Visible = False
   
    Call ClearAll
   
    txtName.SetFocus

End Sub

Private Sub btnExit_Click()
   
    g_sTagListActor = ""
    g_bCancel = True
    Call ClearAll
    DoCmd.Close acForm, Me.Form.Name

End Sub

Private Sub btnFilter_Click()
Dim i As Integer
Dim s1 As String
Dim s2 As String
Dim rst As DAO.Recordset

    Call ClearAll
   
    s2 = ""
   
    If Nz(txtName, "") <> "" Then
        If InStr(txtName, "*") > 0 Then
            s2 = "(Actors.ActorName LIKE ^" & txtName & "^)"
        Else
            s2 = "(Actors.ActorName = ^" & txtName & "^)"
        End If
    End If
   
   
    If s2 = "" Then
        MsgBox "No search criteria given", vbOKOnly + vbExclamation, "Note"
        Exit Sub
    End If
       
    s1 = "SELECT Actors.ActorId, Actors.ActorName," & _
         " IIf(Actors.ActorMainPic > ^^,ReturnActorPic(Actors.ActorMainPic),^^) AS FullName" & _
         " FROM Actors"

    s1 = s1 & " WHERE ("
    s1 = s1 & s2 & ") "
   
    s1 = Replace(s1, "^", Chr$(34))
   
    Select Case Nz(cboOrder, "0")
        Case 0
            'nothing
        Case 1
            s1 = s1 & "ORDER BY Actors.ActorName"
        Case 2
            s1 = s1 & "ORDER BY Actors.ActorName DESC"
    End Select
   
    s1 = s1 & ";"
   
    'Debug.Print s1
   
    Set rst = CurrentDb.OpenRecordset(s1)
    txtCount.Visible = True
   
    If rst.RecordCount = 0 Then
        txtCount = 0
        MsgBox "No records found", vbOKOnly + vbExclamation, "Note"
        Exit Sub
    End If
   
    rst.MoveLast
    rst.MoveFirst
   
    txtCount = rst.RecordCount
    If rst.RecordCount > 200 Then
        MsgBox "Too many records found", vbOKOnly + vbExclamation, "Note"
        Exit Sub
    End If

    txtPageNo = 1
    txtPageMax = (txtCount + 19) \ 20
    Call CheckPage(1)
   
    i = 0
    Do Until rst.EOF
        i = i + 1
        lngActorId(i) = CLng(rst.Fields("ActorId"))
        strActorName(i) = rst.Fields("ActorName")
        strFileName(i) = rst.Fields("FullName")
        blnActorSelected(i) = False
        rst.MoveNext
    Loop
    intActorsMax = i
    rst.Close
    Set rst = Nothing
   
    txtPageNo.Visible = True
    txtPageMax.Visible = True
    txtSelected.Visible = True
    txtSelected = 0
   
    Call DisplayActors(1)
   
End Sub

Private Sub btnLast_Click()
    Call CheckPage(txtPageMax)
End Sub

Private Sub btnNext_Click()
    Call CheckPage(txtPageNo + 1)
End Sub

Private Sub btnPrevious_Click()
    Call CheckPage(txtPageNo - 1)
End Sub

Private Sub btnFirst_Click()
    Call CheckPage(1)
End Sub

Private Sub btnRetFound_Click()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim lngActorsSelected(1 To 20) As Long
Dim blnAlreadySet As Boolean
Dim s As String

    If txtSelected = 0 Then
        If MsgBox("No Actor selected. Exit now?", vbYesNo + vbQuestion, "No Actor") = vbYes Then
            g_sTagListActor = ""
            g_bCancel = True
            DoCmd.Close acForm, Me.Form.Name
            Exit Sub
        End If
    End If
   
    i = 0
    For j = 1 To txtCount
        If blnActorSelected(j) Then
            If i = 0 Then
                i = 1
                lngActorsSelected(i) = lngActorId(j)
            Else
                For k = 1 To i
                    If lngActorsSelected(i) = lngActorId(j) Then
                        blnAlreadySet = True
                        Exit For
                    End If
                    If Not blnAlreadySet Then
                        i = i + 1
                        lngActorsSelected(i) = lngActorId(j)
                    End If
                Next
            End If
        End If
    Next
    For j = 1 To i
        s = s & lngActorsSelected(j) & ", "
    Next
    'MsgBox "Selected: " & s
    g_sActorsSelected = s
    DoCmd.Close acForm, Me.Form.Name

End Sub

Private Sub Form_Load()
Dim i As Integer

    Call ClearAll
   
    btnLast.Visible = False
    btnNext.Visible = False
    btnPrevious.Visible = False
    btnFirst.Visible = False
   
    txtCount.Visible = False
    txtPageNo.Visible = False
    txtPageMax.Visible = False
    txtSelected.Visible = False
   
    btnRetFound.Visible = False
   
End Sub

Public Sub DisplayActors(intStart As Integer)
Dim i As Integer
Dim intTarget As Integer

    For i = 1 To 20
        intTarget = intStart + i - 1
        If Nz(lngActorId(intTarget), 0) > 0 Then
            Me.Controls("txtActor" & i) = strActorName(intTarget)
            Me.Controls("picMain" & i).Picture = strFileName(intTarget)
            If blnActorSelected(intTarget) Then
                Me.Controls("btnDummy" & i).BorderColor = vbRed
                Me.Controls("btnDummy" & i).BorderWidth = 3
            Else
                Me.Controls("btnDummy" & i).BorderColor = vbBlack
                Me.Controls("btnDummy" & i).BorderWidth = 1
            End If
            Call TriggerBox(i, True)
        Else
            Call TriggerBox(i, False)
        End If
       
    Next
   
End Sub
Public Sub CheckPage(ByVal intNewPage As Integer)
Dim i As Integer

    If intNewPage > 20 Then intNewPage = 20
    If intNewPage > txtPageMax Then intNewPage = txtPageMax
    If intNewPage < 1 Then intNewPage = 1
   
    txtPageNo = intNewPage
    btnDummy.SetFocus
   
    If (txtPageNo = 1) And (txtPageMax = 1) Then
        btnLast.Visible = False
        btnNext.Visible = False
        btnPrevious.Visible = False
        btnFirst.Visible = False
    ElseIf txtPageNo = txtPageMax Then
        btnLast.Visible = False
        btnNext.Visible = False
        btnPrevious.Visible = True
        btnFirst.Visible = True
    ElseIf txtPageNo = 1 Then
        btnLast.Visible = True
        btnNext.Visible = True
        btnPrevious.Visible = False
        btnFirst.Visible = False
    Else
        btnLast.Visible = True
        btnNext.Visible = True
        btnPrevious.Visible = True
        btnFirst.Visible = True
    End If
   
    i = (txtPageNo - 1) * 20 + 1
    Call DisplayActors(i)

End Sub
Public Sub ClearAll()
Dim i As Integer

    If intActorsMax > 0 Then
        For i = 1 To intActorsMax
            lngActorId(i) = 0
            strActorName(i) = ""
            strFileName(i) = ""
            blnActorSelected(i) = False
            intActorsMax = 0
        Next
    End If
   
    For i = 1 To 20
        Call TriggerBox(i, False)
        Me.Controls("txtActor" & i) = ""
        Me.Controls("PicMain" & i).Picture = ""
    Next

End Sub

Private Sub Check_txtSelected()
    If txtSelected > 0 Then
        btnRetFound.Visible = True
    Else
        btnRetFound.Visible = False
    End If
End Sub

Noch 'ne Anmerkung:
in einer globalen Funktion stze ich den vollständigen Namen der Bilddatei wie folgt zusammen:
Public Function ReturnActorPic(strPic As String) As String
Dim strFile As String

    If Nz(strPic, "") = "" Then
        ReturnActorPic = ""
        Exit Function
    ElseIf strFile = "_nopic.jpg" Then
        ReturnActorPic = g_sDirActorPics & "_nopic.jpg"
        Exit Function
    End If
   
    If Asc(Left(strPic, 1)) < 64 Then
        strFile = g_sDirActorPics & "0\" & strPic
    Else
        strFile = g_sDirActorPics & Left(strPic, 1) & "\" & strPic
    End If
   
    ReturnActorPic = strFile
   
End Function
Die Bilder liegen in Verzeichnissen unterhalb von g_sDirActorPics (z. B. "d:\bilder\"), die aus dem ersten Buchstaben des Namens bestehen.

Viel Spaß und Gruß,
crystal

Danke 😀