Code Snippet "VBA Access"

Gibt die Felder einer DB-Tabelle nach ihrer natürlichen Reihenfolge aus

Schema gibt Felder normalerweise alphabetisch zurück, deshalb braucht es noch eine Sortierung

'Parameter dieser Prozedur
' - arrvar: ein zweidimensionaler Array, wobei erste Dimension
'     den Datensätzen und zweite Dimension den Spalten entspricht
' - intl: Hilfsvariable für linke Position
' - intr: Hilfsvariable für rechte Position
' - intsortcolumn: Spalte, nach der sortiert wird (beginnt bei 0!)
Sub procarrquicksort(ByRef arrvar, ByVal intl, ByVal intr, ByVal intsortcolumn)
  Dim inti, intj, intpivot, intinnercounter ', vartemp
  Dim arrhelp
  
  ReDim arrhelp(Ubound(arrvar, 2)) 'für jede Spalte 1 Zelle
  
  inti = intl
  intj = intr
  
  intpivot = arrvar((intl + intr) \ 2, intsortcolumn)

  Do
    Do While arrvar(inti, intsortcolumn) < intpivot
      inti = inti + 1
    Loop
    Do While intpivot < arrvar(intj, intsortcolumn)
      intj = intj - 1
    Loop
    
    If inti <= intj Then
      'Response.Write("inti: " & inti & " intj: " & intj & "<br />" & vbCrLf)
      For intinnercounter = 0 To Ubound(arrhelp)
        arrhelp(intinnercounter) = arrvar(intj, intinnercounter)
        arrvar(intj, intinnercounter) = arrvar(inti, intinnercounter)
        arrvar(inti, intinnercounter) = arrhelp(intinnercounter)
      Next
      inti = inti + 1
      intj = intj - 1
    End If
  Loop While inti <= intj
  
  If intl <= intj Then
    Call procarrquicksort(arrvar, intl, intj, intsortcolumn)
  End If
  If inti <= intr Then
    Call procarrquicksort(arrvar, inti, intr, intsortcolumn)
  End If
End Sub

'liefert einen String mit den Feldnamen ohne Felder .._alt zurück
'nicht verwendet, da langsamer als funStrFields
'Funktioniert im Gegensatz zu funStrFields auch, wenn alle Daten einer Tabelle gelöscht sind
'Problem: Cursor für Schema ist statisch -> kein RecordCount, Sort, GetRows möglich
'Manuell in Array abfüllen und mit Quicksort sortieren
Function funStrFieldsWithSchema(ByVal objCon, ByVal strTablename As String, Optional ByVal strTblVorspann As String) As String
  Dim intRow As Integer
  Dim varArrRS()
  Dim strFields As String
  Dim objRsSchema As New ADODB.Recordset
  Dim objRs As New ADODB.Recordset
  
  'objRsSchema.CursorLocation = adUseClient
  objRsSchema.CursorLocation = adUseClient
  Set objRsSchema = objCon.OpenSchema(4)

  If Not Err.Number = 3251 Then
    'Anzahl Felder in Tabelle zählen
    intRow = 0
    Do Until objRsSchema.EOF
      If Lcase(objRsSchema("TABLE_NAME")) = Lcase(strTablename) Then
        intRow = intRow + 1
      End If
      objRsSchema.MoveNext
    Loop
    'Array für diese Anzahl Felder redimensionieren
    ReDim varArrRS(intRow, 2)
    
    'Felder in Array abfüllen
    objRsSchema.MoveFirst
    intRow = 0
    Do Until objRsSchema.EOF
      If Lcase(objRsSchema("TABLE_NAME")) = Lcase(strTablename) Then
        'ReDim geht nicht direkt, weil nur letzte Dimension vergrössert werden kann
        varArrRS(intRow, 0) = objRsSchema("ORDINAL_POSITION")
        varArrRS(intRow, 1) = objRsSchema("COLUMN_NAME")
        intRow = intRow + 1
      End If
      objRsSchema.MoveNext
    Loop
    
    'Sortieren nach Feldposition (normal alphabetisch nach Feldname)
    Call procarrquicksort(varArrRS, 0, Ubound(varArrRS, 1) - 1, 0)
    
    For intRow = 0 To Ubound(varArrRS) - 1
      If Right(varArrRS(intRow, 1), 4) <> "_alt" Then
        If strTblVorspann <> "" Then
          strFields = strFields & "[" & strTblVorspann & "].[" & varArrRS(intRow, 1) & "], "
        Else
          strFields = strFields & "[" & varArrRS(intRow, 1) & "], "
        End If
      End If
    Next
  End If

  objRsSchema.Close
  Set objRsSchema = Nothing
  strFields = Left(strFields, Len(strFields) - 2)
  funStrFieldsWithSchema = strFields
End Function

Sub procTestFunStrFields()
  Set objCon = CurrentProject.Connection
  strDatasource = objCon.Properties("Data Source")
  Debug.Print (funStrFieldsWithSchema(objCon, "tbl_AB_Verarbeitet", "tbl_AB_Verarbeitet"))
End Sub