Sie sind hier: Arrays from Recordset
Weiter zu: Weitere nützliche VBA Funktionen für Access
Allgemein: Downloads Kontakt Impressum Haftungsausschluss Von A-Z Sitemap Blog

Suchen nach:

Arrays from Recordset

Arrays from Recordset

'' Working with Arrays from Recordsets
'' ###################################

'Creating a two-dimensional array from a table
'AccessArray(iSpalte,iZeile) <0, 0>

Function ArrFill_DAO_Alt(ByVal recsetSQL As String, ByRef iZLMax As Long, ByRef iColMax As Long, ByRef DAOARRAY) As Boolean

Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim I As Long

''Just for copy and paste
'Dim ArrFill_DAO_Alt_OK1 As Boolean, recsetSQL1 As String, iZLMax1 As Long, iColMax1 As Long, DAOARRAY1
'ArrFill_DAO_Alt_OK1 = ArrFill_DAO_Alt(recsetSQL1,iZLMax1,iColMax1,DAOARRAY1)
''Info: 'AccessArray(<iSpalte,iZeile> / <iColumn, iRow>) <0, 0>

ArrFill_DAO_Alt = False

Set db = CurrentDb
Set rst = db.OpenRecordset(recsetSQL)
If rst.RecordCount <> 0 Then
rst.MoveLast
I = rst.RecordCount
rst.MoveFirst
DAOARRAY = rst.GetRows(I)

'Achtung Zeile und Spalte 0-basiert
'RowArray(iFldNr,iRecNr)
'RowArray(iSpalte,iZeile)
iZLMax = UBound(DAOARRAY, 2)
iColMax = UBound(DAOARRAY, 1)
ArrFill_DAO_Alt = True
End If
rst.Close
Set rst = Nothing

End Function

' Access creates a two-dim recordset which is zero-based 'AccessArray(<iSpalte,iZeile> / <iColumn, iRow> / <iFldNr, iRecNr>) <0, 0>
' Excel creates / reads a two-dim recordset which is 1-based 'ExcelArray(<iZeile, iSpalte> / <iRow, iColumn> / <iRecNr, iFldNr> ) <1, 1>
' This Function is able to create an Access or Excel-Array and additional a second array containing the name and type of the fields
' The second array is in the same format that the main (first) one.

'Creating a two-dimensional array from a table
'AccessArray(iSpalte,iZeile) <0, 0>
'Additionally it creates an Array, which can be read directly from Excel

Function ArrFill_DAO(ByVal recsetSQL As String, ByRef iZLMax As Long, ByRef iColMax As Long, ByRef DAOARRAY, Optional ByRef DAOARRAY_Name, Optional AsExcel As Boolean = False) As Boolean

Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim I As Long
Dim j As Long

''Just for copy and paste
'Dim ArrFill_DAO_OK1 As Boolean, recsetSQL1 As String, iZLMax1 As Long, iColMax1 As Long, DAOARRAY1, DAOARRAY_Name1, iZl as long, iCol as long
'ArrFill_DAO_OK1 = ArrFill_DAO(recsetSQL1,iZLMax1,iColMax1,DAOARRAY1,DAOARRAY_Name1)
''Info: 'AccessArray(iSpalte,iZeile) <0, 0> 'ExcelArray(iZeile, iSpalte) <1, 1>

Dim NumArray
Dim NumtxtArray

Dim tmpArry
Dim iLbound As Long
Dim iCol As Long

NumArray = Array(dbBigInt, dbBinary, dbBoolean, dbByte, dbChar, dbCurrency, dbDate, dbDecimal, dbDouble, dbFloat, dbGUID, dbInteger, dbLong, dbLongBinary, dbMemo, dbNumeric, dbSingle, dbText, dbTime, dbTimeStamp, dbVarBinary)
NumtxtArray = Array("dbBigInt", "dbBinary", "dbBoolean", "dbByte", "dbChar", "dbCurrency", "dbDate", "dbDecimal", "dbDouble", "dbFloat", "dbGUID", "dbInteger", "dbLong", "dbLongBinary", "dbMemo", "dbNumeric", "dbSingle", "dbText", "dbTime", "dbTimeStamp", "dbVarBinary")

ArrFill_DAO = False

Set db = CurrentDb
Set rst = db.OpenRecordset(recsetSQL)
If rst.RecordCount <> 0 Then
rst.MoveLast
I = rst.RecordCount
rst.MoveFirst

If AsExcel = True Then
tmpArry = rst.GetRows(I)
iLbound = 1
Call ArrFill_Transform2d(tmpArry, DAOARRAY, True, iZLMax, iColMax)
Erase tmpArry
Set tmpArry = Nothing
ArrFill_DAO = True
Else
DAOARRAY = rst.GetRows(I)
iLbound = 0
iZLMax = UBound(DAOARRAY, 2)
iColMax = UBound(DAOARRAY, 1)
ArrFill_DAO = True
End If

'Function ArrFill_DAO(ByVal recsetSQL As String, ByRef iZLMax As Long, ByRef iColMax As Long, ByRef DAOARRAY) As Boolean

'Achtung Zeile und Spalte 0-basiert
'RowArray(iFldNr,iRecNr)
'AccessArray(iSpalte,iZeile) <0, 0>
'ExcelArray(iZeile, iSpalte) <1, 1>

'Zusatztabelle mit Feldnamen (Zeile 0) und Feldtypen als Long (Zeile 1) und als Text (Zeile 2)
If Not IsMissing(DAOARRAY_Name) Then

If AsExcel = True Then
'ExcelArray(iZeile, iSpalte) <1, 1>
ReDim DAOARRAY_Name(iLbound To 2 + iLbound, iLbound To iColMax)

For iCol = iLbound To iColMax
DAOARRAY_Name(iLbound, iCol) = rst.Fields(iCol - iLbound).Name
DAOARRAY_Name(iLbound + 1, iCol) = rst.Fields(iCol - iLbound).Type
For j = 0 To UBound(NumArray)
If NumArray(j) = rst.Fields(iCol - iLbound).Type Then
DAOARRAY_Name(iLbound + 2, iCol) = NumtxtArray(j)
Exit For
End If
Next j
Next iCol

Else
'AccessArray(iSpalte, iZeile) <0, 0>
ReDim DAOARRAY_Name(iLbound To iColMax, iLbound To 2 + iLbound)

For iCol = iLbound To iColMax
DAOARRAY_Name(iCol, iLbound) = rst.Fields(iCol).Name
DAOARRAY_Name(iCol, iLbound + 1) = rst.Fields(iCol).Type
For j = 0 To UBound(NumArray)
If NumArray(j) = rst.Fields(iCol).Type Then
DAOARRAY_Name(iCol, iLbound + 2) = NumtxtArray(j)
Exit For
End If
Next j
Next iCol

End If
End If

End If
rst.Close
Set rst = Nothing

End Function



Function ArrFill_Transform2d(InArray, OutArray, bToExcel As Boolean, iZLMaxOut As Long, iColMaxOut As Long) As Boolean
'Converts an array from Access to Excel and vice versa

'bToExcel = True -- from Access to Excel
'bToExcel = False -- from Excel to Access

'Access-Arrays:
'Achtung Zeile und Spalte 0-basiert
'AccessArray(iFldNr, iRecNr)
'AccessArray(iSpalte, iZeile) <0, 0>

'Excel-Arrays:
'Achtung Zeile und Spalte 1-basiert
'ExcelArray(iRecNr, iFldNr)
'ExcelArray(iZeile, iSpalte) <1, 1>



'Dim ArrFill_Transform2d_OK1 As Boolean, InArray1, OutArray1, iZLMaxOut1, iColMaxOut1, iZl as long, iCol as long
'ArrFill_Transform2d_OK1 = ArrFill_Transform2d(InArray1,OutArray1,True, iZLMaxOut1,iColMaxOut1)
''Info: 'AccessArray(iSpalte,iZeile) <0, 0> 'ExcelArray(iZeile, iSpalte) <1, 1>

Dim I As Long, ii As Long, j As Long
Dim IZlIn As Long
Dim IColIn As Long
Dim IZl2In As Long
Dim ICol2In As Long

On Error GoTo Fehl

ArrFill_Transform2d = True

If bToExcel = True Then
ii = 1 ' Ziel Array Excel: 1 größer
Else
ii = -1 ' Ziel Array Access: 1 kleiner
End If

If bToExcel = False Then ' Von Excel Nach Access
'OutArray(iSpalte, iZeile)

IColIn = LBound(InArray, 2)
ICol2In = UBound(InArray, 2)
IZlIn = LBound(InArray, 1)
IZl2In = UBound(InArray, 1)

ReDim OutArray(IColIn + ii To ICol2In + ii, IZlIn + ii To IZl2In + ii)

For I = IZlIn To IZl2In
For j = IColIn To ICol2In
OutArray(j + ii, I + ii) = InArray(I, j)
Next j
Next I

Else ' Von Access Nach Excel
'OutArray(iZeile, iSpalte)

IColIn = LBound(InArray, 1)
ICol2In = UBound(InArray, 1)
IZlIn = LBound(InArray, 2)
IZl2In = UBound(InArray, 2)

ReDim OutArray(IZlIn + ii To IZl2In + ii, IColIn + ii To ICol2In + ii)

For I = IZlIn To IZl2In
For j = IColIn To ICol2In
OutArray(I + ii, j + ii) = InArray(j, I)
Next j
Next I
End If

iZLMaxOut = IZl2In + ii
iColMaxOut = ICol2In + ii

Exit Function

Fehl:

ArrFill_Transform2d = False

MsgBox "Error - something went wrong"

End Function



Function Fill_Tbl(ByVal recsetSQL As String, ByRef DAOARRAY As Variant) As Boolean

'Dim Fill_Tbl_OK1 As Boolean, trecsetSQL1 As String, InArray1
'Fill_Tbl_OK1 = Fill_Tbl((recsetSQL1,iFirstCol,InArray1)
''Info: 'AccessArray(iSpalte,iZeile) <0, 0> 'ExcelArray(iZeile, iSpalte) <1, 1>

Dim iZl As Long
Dim iCol As Long

Dim I As Long
Dim j As Long
Dim k As Long

'AccessArray(iSpalte,iZeile) <0, 0>
'ExcelArray(iZeile, iSpalte) <1, 1>

Dim db As DAO.Database
Dim rst As DAO.Recordset



' On Error GoTo Fill_Tbl_Error

k = LBound(DAOARRAY, 1)

If k = 0 Then
iCol = UBound(DAOARRAY, 1)
iZl = UBound(DAOARRAY, 2)
Else
iCol = UBound(DAOARRAY, 2)
iZl = UBound(DAOARRAY, 1)
End If

Set db = CurrentDb
Set rst = db.OpenRecordset(recsetSQL)

With rst
For I = k To iZl
.AddNew
For j = k To iCol
On Error Resume Next
If k = 0 Then
.Fields(j) = Nz(DAOARRAY(j, I))
Else
.Fields(j - k) = Nz(DAOARRAY(I, j))
End If
On Error GoTo 0
Next j
.Update
Next I
.Close
End With

Set rst = Nothing

On Error GoTo 0

Fill_Tbl = True
Exit Function

Fill_Tbl_Error:

Fill_Tbl = False
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Fill_Tbl of Module mdlSonstiges4"

End Function