Heute wollen wir Ihnen eine Sortierroutine für ein Access-Formular vorstellen. Funktionieren soll das Ganze so:
Wir benötigen hierzu:
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: DoCmd.GoToControl "GeräteNr" ' in die Spalte gehen DoCmd.FindRecord AKTGRNR, , False, , True ' gemerkten Aktuellen Datensatz finden Anmerkung: Dieser Tipp wurde bereits 23.804 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. |
||||||||||||||||
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. |