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.806 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. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung 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. sevWizard für VB5/6 Professionelle Assistenten im Handumdrehen Erstellen Sie eigene Assistenten (Wizards) im Look & Feel von Windows 2000/XP - mit allem Komfort und zwar in Windeseile :-) |
||||||||||||||||
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. |