vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Erstellen von dynamischen Kontextmen?s - wann immer Sie sie brauchen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Access   |   VB-Versionen: VBA16.08.05
ACCESS: Nach n Formular-Spalten sortieren

Mit 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ädtBewertung:     [ Jetzt bewerten ]Views:  21.898 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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".
 

Dieser Tipp wurde bereits 21.898 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel