Textversion
Lebenslauf Referenzen Consulting Nützliches KnowHow.MDB PASS Deutschland e.V.
Startseite KnowHow.MDB Weitere nützliche VBA Funktionen für Access Arrays from Recordset

KnowHow.MDB


KnowHow.MDB Freeware Kalender Tool Weitere nützliche VBA Funktionen für Access

Arrays from Recordset Datasheet / Datenblatt

Downloads Kontakt Impressum Haftungsausschluss Von A-Z Sitemap Blog

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

Druckbare Version