Attribute VB_Name = "modSortListbox"
Option Compare Database

' ********************************************************************************************
' Dies Modul dient dazu, Listboxen in Access durch einen Klick auf die Kopfzeilen zu sortieren.
' Der Sourcecode darf frei verwendet werden, es besteht keine Haftung für die Funktion!
'
' Autor:    Werner Mager
' Webseite: blog.sternico.de
'
' ********************************************************************************************


Function getColumn(X, lf As Object) As Integer
  
  Dim columns
  columns = Split(lf.ColumnWidths, ";")
  sum = 0
  
  While sum < X And getColumn <= UBound(columns)
    ' summiere Breite
    sum = sum + CInt(columns(getColumn))
    getColumn = getColumn + 1
  Wend
    
End Function


Function SortListbox(lf As ListBox, X As Single, Y As Single)
  If Y <= 210 Then
    DoCmd.Hourglass True
    Column = getColumn(X, lf)
    header$ = lf.Column(Column - 1, 0)
    If Not IsNull(header) Then
      reordered = reOrder(lf.rowsource, header$)
      lf.rowsource = reordered
    End If
    DoCmd.Hourglass False
  End If
End Function

Function reOrder(rowsource As String, byWhat As String)

  ' Leerzeichen entfernen
  rowsource = Trim(rowsource)
  ' Falls byWhat einen Alias hat, diesen ermitteln
  byWhat = getAlias(rowsource, byWhat)
  
  ' Direkte Quelle?
  If Not (Mid(rowsource, 1, 6) = "select") Then
    reOrder = "SELECT * from " & rowsource & " ORDER by " & byWhat & ";"
  Else
    ' SQl-String?
    reOrder = removeOrderBy(rowsource) & " ORDER by " & byWhat & ";"
    ' Beim zweiten Klick absteigend sortieren
    If (rowsource = reOrder) And InStr(reOrder, "DESC") = 0 Then
      reOrder = Mid(reOrder, 1, Len(reOrder) - 1) + " DESC;"
    End If
  End If
 
End Function

Function removeOrderBy(src As String)
  i = InStr(src, "ORDER by")
  If Not (i = 0) Then
    removeOrderBy = Trim(Mid(src, 1, i - 1))
    Exit Function
  End If
  If Mid(src, Len(src)) = ";" Then
    removeOrderBy = Trim(Mid(src, 1, Len(src) - 1))
    Exit Function
  End If
  removeOrderBy = Trim(src)
End Function

Function getAlias(sqlstr As String, obj As String) As String
  ' Suche in String
  i = InStr(sqlstr, " " + obj)
  If i = 0 Then
    i = InStr(sqlstr, "[" + obj)
  End If
  If Not (i = 0) Then
    ' Wenn direkt davor "as [" oder "as " steht,
    If Trim(Mid(sqlstr, i - 3, 3)) = "as" Then
      getAlias = lastWord(Mid(sqlstr, 1, i - 4))
      Exit Function
    End If
  End If
  ' sonst existiert kein alias
  getAlias = "[" & obj & "]"
End Function

Function lastWord(str As String) As String
  Dim words
  words = Split(str, " ")
  lastWord = words(UBound(words))
End Function