| Rubrik: Access | VB-Versionen: VBA | 16.08.05 |
 ACCESS: Nach n Formular-Spalten sortierenMit diesem Code wollen wir Ihnen eine Sortierroutine für ein Access-Formular vorstellen, mit der sich eine Tabelle nach mehreren Spalten auf-/ und absteigend sortieren lässt. | ||
Autor:  Richard Mittelstädt | Bewertung:   | Views: 23.819 |
| ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 |  Beispielprojekt auf CD |
Heute wollen wir Ihnen eine Sortierroutine für ein Access-Formular vorstellen. Funktionieren soll das Ganze so:
- bei Klick auf einen Spaltenkopf soll nach dieser Spalte sortiert werden
- bei einem nochmaligen Klick auf den Spaltenkopf soll abwärts (DESC) sortiert werden
- der aktuell angeklickte Spaltenkopf soll dann vertieft und mit anderer Textfarbe dargestellt werden
- zusätzlich soll noch ein Auf-/Ab-Pfeil - je nach Sortierrichtung - im Spaltenkopf erscheinen
- die aktuelle Sortierung soll immer in der Statuszeile ganz unten angezeigt werden
Wir benötigen hierzu:
- ein Formular mit Formular-Kopf und Datensätze im Detailbereich, tabellarische Anordnung
- für die Spaltenüberschriften im Formular-Kopf verwenden wir Bezeichnungsfelder
- ein zusätzliches Bezeichnungsfeld um den Auf-/Ab-Pfeil anzuzeigen mit folgenden Eigenschaften:
- (In den Vordergrund bringen)
- Name: PfeilSortierung
- HintergrundArt: Transparent
- Beschriftung: é
- SchriftArt: Wingdings
Auf dem verwendeten Formular sollten keine Filter gesetzt sein. Um zu ortieren verwenden wir die OrderBy-Eigenschaft des Formulars. Sämtliche ezeichnungsfelder im Formular-Kopf auf die die Sortierroutine angewandt werden soll, müssen in der Tag-Eigenschaft den selben Wert haben, z. B. "12345" wie in unserem Beispiel verwendet.
Doch nun zum Code. Wir benötigen zwei Module:
1. Modul_GlobaleVariable, das lediglich eine Variable enthält:
Option Compare Database Option Explicit Global ORDERSTR ' globaler Sortier-String z.B. Screen.ActiveForm.OrderBy
2. Modul_Sortierung, in das der gesamte restliche Code gepackt wird:
Option Compare Database Option Explicit Public Function SortierungUmstellen(Feld1 As String, BezFeld As String) ' die Parameter beziehen sich auf ' 1) Formular-Herkunfts-Abfrage/Tabelle, ' 2) Name des angeklickten Bezeichnungsfeldes DoCmd.Hourglass True Application.Echo False Dim FARBEAUF, FARBEAB FARBEAUF = 255 ' Rot, Sortier-Farbe für FeldÜberschriften(rot, Aufsteigend) FARBEAB = 8388608 ' Blau, Sortier-Farbe für FeldÜberschriften(blau, Absteigend) On Error GoTo Err_SortierungUmstellen ' !!!! Spätere Suchfehler abblocken !!!!!! Dim Form1 As Form Set Form1 = Screen.ActiveForm Dim ctl As Control Dim ctl1 As Control Form1.Refresh ' Formular (Satz speichern) ' AKT_LNR_GLOBAL = Screen.ActiveForm.[LNr] ' Aktuellen Datensatz merken ' MsgBox AKTID & " " & 1 ' ********* alle Bezeichnungs-Felder mit Tag "12345"-Eintrag erhöht + schwarz darstellen ******** ' andere Bez-Felder müssen einen anderen Tag-Eintrag "" bekommen ! Dim GEF GEF = False For Each ctl In Form1.Section(1).Controls ' Controls-Auflistung durchlaufen. ' Ist Steuerelement ein Bez.Feld mit Tag = "12345" ? If ctl.ControlType = acLabel And ctl.Tag = "12345" Then With ctl If ctl.Name = BezFeld Then ' MsgBox ctl.Name GEF = True ' Aktives Sortierungs-Bezeichnungsfeld gefunden! ctl.SpecialEffect = 2 ' vertieft ctl.ForeColor = 0 ' Bezeichnungsfeld erst mal schwarz ! Set ctl1 = ctl Else ctl.SpecialEffect = 1 ' erhöht ctl.ForeColor = 0 ' Bezeichnungsfeld schwarz ! End If End With End If Next ctl ' ***************** Sortierstring mehr-fach bilden 2005-07-21 **************** Dim O_STRING ' ORDERBY-String von/für Formular Dim POS_AUF As Integer ' Erste Zeichen-Pos. des 1.Vokommens von Feld1 AUF-Steigend Dim POS_AB As Integer ' Erste Zeichen-Pos. des 1.Vokommens von Feld1 AB-/Absteigend Dim ANZ_EBENEN As Integer ' Anzahl der zu behandelnden Sortier-Ebenen Dim SORT_AUF As Boolean ' Aufwärts sortieren notwendig ? ANZ_EBENEN = 3 ' Anzahl der gewünschten max. Sortier-Ebenen Dim i As Long Dim POS_KOMMA As Integer ' Zeichen-Pos. "Ebenen-" Komma Dim POS_KOMMA_TEMP As Integer ' Zeichen-Pos. temp. von Komma bzw. i-tem Komma ' *** Alle Leerzeichen nach jedem Komma (macht ACCESS aut.!) in ORDERBY streichen ****** O_STRING = ErsetzenTextTeil(Screen.ActiveForm.OrderBy, ", ", ",") ' *** links und rechts mit Komma ausstatten ! *********************** If Len(O_STRING) > 0 Then If Not Left(O_STRING, 1) = "," Then O_STRING = "," & O_STRING End If If Not Right(O_STRING, 1) = "," Then O_STRING = O_STRING & "," End If Else ' 2005-08-16 Desc! bei "Noch keiner Sortierung" dazu ' -> wird dann gleich (1.Klick-Standard-) Auf-Sortierg. O_STRING = "," & Feld1 & " DESC," End If ' *** Jetzt stehen alle Terme genau zwischen 2 Kommas ! ********************** POS_AUF = InStr(1, O_STRING, "," & Feld1 & ",") POS_AB = InStr(1, O_STRING, "," & Feld1 & " DESC" & ",") If POS_AUF > 1 Then ' kommt schon vor als AUF (NICHT links) O_STRING = ErsetzenTextTeil(O_STRING, "," & Feld1 & ",", ",") ' Löschen ! O_STRING = "," & Feld1 & O_STRING ' -> neu nach links als AUF SORT_AUF = True ElseIf POS_AB > 1 Then ' kommt schon vor als AB (NICHT links) O_STRING = ErsetzenTextTeil(O_STRING, "," & Feld1 & " DESC" & ",", ",") ' Löschen ! O_STRING = "," & Feld1 & O_STRING ' -> neu nach links als AUF SORT_AUF = True ElseIf POS_AUF = 1 Then ' kommt schon vor als AUF (links) O_STRING = ErsetzenTextTeil(O_STRING, "," & Feld1 & ",", ",") ' Löschen ! O_STRING = "," & Feld1 & " DESC" & O_STRING ' -> neu nach links als AB SORT_AUF = False ElseIf POS_AB = 1 Then ' kommt schon vor als AB (links) O_STRING = ErsetzenTextTeil(O_STRING, "," & Feld1 & " DESC" & ",", ",") ' Löschen ! O_STRING = "," & Feld1 & O_STRING ' -> neu nach links als AUF SORT_AUF = True Else ' Feld kommt neu in die Sortierung dazu nach links als AUF O_STRING = "," & Feld1 & O_STRING ' -> neu nach links als AUF SORT_AUF = True End If ' *** Sortier-Ebenen begrenzen auf ANZ_EBENEN **************************** i = 0 POS_KOMMA_TEMP = 2 Do While POS_KOMMA_TEMP > 0 And i < ANZ_EBENEN POS_KOMMA_TEMP = InStr(POS_KOMMA_TEMP + 1, O_STRING, ",") If POS_KOMMA_TEMP > 0 Then i = i + 1 POS_KOMMA = POS_KOMMA_TEMP End If Loop ' *** Nur linker Teil (bis einschl. POS_KOMMA_TEMP ) ! ************* O_STRING = Left(O_STRING, POS_KOMMA) ' ************************************************************************* ' *** links und rechts die Kommas wieder wegnehmen ! ****** O_STRING = Left(O_STRING, Len(O_STRING) - 1) O_STRING = Right(O_STRING, Len(O_STRING) - 1) Screen.ActiveForm.OrderBy = O_STRING Screen.ActiveForm.OrderByOn = True ORDERSTR = Screen.ActiveForm.OrderBy Screen.ActiveForm.Refresh If GEF Then ' --- Wingdings-Pfeil sichtbar und positionieren --- Screen.ActiveForm![PfeilSortierung].Visible = True Screen.ActiveForm![PfeilSortierung].Top = ctl1.Top + 40 Screen.ActiveForm![PfeilSortierung].Left = ctl1.Left + ctl1.Width - Screen.ActiveForm![PfeilSortierung].Width - 50 If SORT_AUF = False Then ' Bezeichnungsfeld gefunden, Farbe für Absteigend ! ctl1.ForeColor = FARBEAB Screen.ActiveForm![PfeilSortierung].Caption = "ê" ' Wingdings-Pfeil nach unten Else ' Bezeichnungsfeld gefunden, Farbe für Aufsteigend ! ctl1.ForeColor = FARBEAUF Screen.ActiveForm![PfeilSortierung].Caption = "é" ' Wingdings-Pfeil nach oben End If End If Call RecordsourceInStatuszeile(Form1.RecordSource) ' ************* Alles ab hier wird bei Suchfehler-error abgeblockt ! : ***** ????? Dim rst Set rst = CurrentDb.OpenRecordset(Screen.ActiveForm.RecordSource, dbOpenSnapshot) If Not rst.RecordCount = 0 Then ' Standard-Suchoptionen setzen(Alle Felder, Teil des Feldinhaltes usw. ) DoCmd.FindRecord "Hier Suchstring_eingeben!!!", acAnywhere, False, acSearchAll, True, acAll, True End If rst.Close Application.Echo True DoCmd.Hourglass False Exit_SortierungUmstellen: Exit Function Err_SortierungUmstellen: Application.Echo True DoCmd.Hourglass False MsgBox Err.Number & " " & Err.Description Resume Exit_SortierungUmstellen End Function
Public Function ErsetzenTextTeil(ALL_TXT, SUCH_TXT, ERSATZ_TXT) ' ************************************************************************* ' ALL_TXT zu untersuchender Text ' SUCH_TXT zu suchender und zu ersetzender Text ' ERSATZ_TXT Ersatz für gefundenen Such_txt ' ************************************************************************* Dim STR1 As String, TEIL_1, TEIL_2 STR1 = ALL_TXT Dim Pos Pos = InStr(1, STR1, SUCH_TXT, vbTextCompare) ' 1.Position von SUCH_TXT ermitteln Do Until Pos = 0 TEIL_1 = Left(STR1, Pos - 1) ' 2 Teile, SUCH_TXT wegnehmen TEIL_2 = Right(STR1, Len(STR1) - (Pos - 1) - Len(SUCH_TXT)) STR1 = TEIL_1 & ERSATZ_TXT & TEIL_2 ' Ersatz-TXT dazwischen einfügen Pos = InStr(1, STR1, SUCH_TXT, vbTextCompare) ' nächste Position von SUCH_TXT ermitteln Loop ErsetzenTextTeil = STR1 End Function
Public Function RecordsourceInStatuszeile(FSOURSE_TXT) ' Source-Text links abschneiden ! Dim SYSTEXT As String, X SYSTEXT = FSOURSE_TXT X = SysCmd(acSysCmdClearStatus) ' StatusAnzeige zurücksetzen If InStr(SYSTEXT, " WHERE ") = 0 Then SYSTEXT = "(keine aktiven Suchstrings...)" Else ' Links abschneiden einschl. "WHERE" SYSTEXT = Right(SYSTEXT, Len(SYSTEXT) - 5 - InStr(SYSTEXT, " WHERE ")) End If If Len(Screen.ActiveForm.OrderBy) > 0 Then SYSTEXT = SYSTEXT & " {Sortiert: " & Screen.ActiveForm.OrderBy & "}" End If X = SysCmd(acSysCmdSetStatus, SYSTEXT) ' auf aktuellen Source setzen End Function
Hinweis:
Vor dem Aufruf der Sortierung sollte man sich den aktuellen Satz merken (anhand laufender Nummer oder eindeutiger Bezeichnung) und danach wieder zu diesem Satz gehen, z.B.:
DoCmd.GoToControl "GeräteNr" ' in die Spalte gehen DoCmd.FindRecord AKTGRNR, , False, , True ' gemerkten Aktuellen Datensatz finden
Anmerkung:
Voraussetzung, dass obiger Code korrekt funktioniert, ist das Aktivieren des Verweises auf die "Microsoft DAO 3.6 Library".
