MS-Access Recordset och Class Module

Introduktion.

Här kommer vi att bygga en klassmodul för databearbetningsuppgifter, en DAO.Recordset Objektet kommer att skickas till det anpassade klassobjektet. Eftersom det är ett objekt som går vidare till vår anpassade klass behöver vi uppsättningen ochHämta Egenskapsprocedurpar för att tilldela och hämta objektet eller dess egenskapsvärden.

Vi har en liten tabell:Tabell1 , med få skivor i den. Här är bilden av Tabell 1.

Tabellen ovan har bara fyra fält:Desc, Qty, UnitPrice och TotalPrice. Fältet Totalpris är tomt.

• En av uppgifterna för vår klassmodul är att uppdatera fältet TotalPrice med produkten av kvantitet * enhetspris.
• Klassmodulen har en subrutin för att sortera data i det användarspecificerade fältet och dumpar en lista i felsökningsfönstret.
• En annan subrutin skapar en kopia av tabellen med ett nytt namn, efter att ha sorterat data baserat på kolumnnumret som anges som en parameter.

ClsRecUpdate Class Module.

1. Öppna din Access-databas och öppna VBA-fönstret.
2. Infoga en klassmodul.
3. Ändra dess namnegenskapsvärde till ClsRecUpdate .
4. Kopiera och klistra in följande kod i klassmodulen och spara modulen:
   

   Option Compare Database
   Option Explicit
   
   Private rstB As DAO.Recordset
   
   Public Property Get REC() As DAO.Recordset
      Set REC = rstB
   End Property
   
   Public Property Set REC(ByRef oNewValue As DAO.Recordset)
   If Not oNewValue Is Nothing Then
      Set rstB = oNewValue
   End If
   End Property
   
   Public Sub Update(ByVal Source1Col As Integer, ByVal Source2Col As Integer, ByVal updtcol As Integer)
   'Updates a Column with the product of two other columns
   Dim col As Integer
   
   col = rstB.Fields.Count
   
   'Validate Column Parameters
   If Source1Col > col Or Source2Col > col Or updtcol > col Then
       MsgBox "One or more Column Number(s) out of bound!", vbExclamation, "Update()"
       Exit Sub
   End If
   
   'Update Field
   On Error GoTo Update_Err
   rstB.MoveFirst
   Do While Not rstB.EOF
      rstB.Edit
        With rstB
         .Fields(updtcol).Value = .Fields(Source1Col).Value * .Fields(Source2Col).Value
         .Update
         .MoveNext
        End With
   Loop
   
   Update_Exit:
   rstB.MoveFirst
   Exit Sub
   
   Update_Err:
   MsgBox Err & " : " & Err.Description, vbExclamation, "Update()"
   Resume Update_Exit
   End Sub
   
   Public Sub DataSort(ByVal intCol As Integer)
   Dim cols As Long, colType
   Dim colnames() As String
   Dim k As Long, colmLimit As Integer
   Dim strTable As String, strSortCol As String
   Dim strSQL As String
   Dim db As Database, rst2 As DAO.Recordset
   
   On Error GoTo DataSort_Err
   
   cols = rstB.Fields.Count - 1
   strTable = rstB.Name
   strSortCol = rstB.Fields(intCol).Name
   
   'Validate Sort Column Data Type
   colType = rstB.Fields(intCol).Type
   Select Case colType
       Case 3 To 7, 10
           strSQL = "SELECT " & strTable & ".* FROM " & strTable & " ORDER BY " & strTable & ".[" & strSortCol & "];"
           Debug.Print "Sorted on " & rstB.Fields(intCol).Name & " Ascending Order"
   
       Case Else
           strSQL = "SELECT " & strTable & ".* FROM " & strTable & ";"
   
           Debug.Print "// SORT: COLUMN: <<" & strSortCol & " Data Type Invalid>> Valid Type: String,Number & Currency //"
           Debug.Print "Data Output in Unsorted Order"
   End Select
   
   Set db = CurrentDb
   Set rst2 = db.OpenRecordset(strSQL)
   
   ReDim colnames(0 To cols) As String
   
   'Save Field Names in Array to Print Heading
   For k = 0 To cols
      colnames(k) = rst2.Fields(k).Name
   Next
   
   'Print Section
   Debug.Print String(52, "-")
   
   'Print Column Names as heading
   If cols > 4 Then
      colmLimit = 4
   Else
      colmLimit = cols
   End If
   For k = 0 To colmLimit
       Debug.Print colnames(k),
   Next: Debug.Print
   Debug.Print String(52, "-")
   
   'Print records in Debug window
   rst2.MoveFirst
   Do While Not rst2.EOF
     For k = 0 To colmLimit 'Listing limited to 5 columns only
        Debug.Print rst2.Fields(k),
     Next k: Debug.Print
   rst2.MoveNext
   Loop
   
   rst2.Close
   Set rst2 = Nothing
   Set db = Nothing
   
   DataSort_Exit:
   Exit Sub
   
   DataSort_Err:
   MsgBox Err & " : " & Err.Description, vbExclamation, "DataSort()"
   Resume DataSort_Exit
   
   End Sub
   
   Public Sub TblCreate(Optional SortCol As Integer = 0)
   Dim dba As DAO.Database, tmp() As Variant
   Dim tbldef As DAO.TableDef
   Dim fld As DAO.Field, idx As DAO.Index
   Dim rst2 As DAO.Recordset, i As Integer, fldcount As Integer
   Dim strTable As String, rows As Long, cols As Long
   
   On Error Resume Next
   
   strTable = rstB.Name & "_2"
   Set dba = CurrentDb
   
   On Error Resume Next
   TryAgain:
   Set rst2 = dba.OpenRecordset(strTable)
   If Err > 0 Then
     Set tbldef = dba.CreateTableDef(strTable)
     Resume Continue
   Else
     rst2.Close
     dba.TableDefs.Delete strTable
     dba.TableDefs.Refresh
     GoTo TryAgain
   End If
   Continue:
   On Error GoTo TblCreate_Err
   
   fldcount = rstB.Fields.Count - 1
   ReDim tmp(0 To fldcount, 0 To 1) As Variant
   
   'Save Source File Field Names and Data Type
   For i = 0 To fldcount
       tmp(i, 0) = rstB.Fields(i).Name: tmp(i, 1) = rstB.Fields(i).Type
   Next
   'Create Fields and Index for new table
   For i = 0 To fldcount
      tbldef.Fields.Append tbldef.CreateField(tmp(i, 0), tmp(i, 1))
   Next
   'Create index to sort data
   Set idx = tbldef.CreateIndex("NewIndex")
   With idx
      .Fields.Append .CreateField(tmp(SortCol, 0))
   End With
   'Add Tabledef and index to database
   tbldef.Indexes.Append idx
   dba.TableDefs.Append tbldef
   dba.TableDefs.Refresh
   
   'Add records to the new table
   Set rst2 = dba.OpenRecordset(strTable, dbOpenTable)
   rstB.MoveFirst 'reset to the first record
   Do While Not rstB.EOF
      rst2.AddNew 'create record in new table
       For i = 0 To fldcount
           rst2.Fields(i).Value = rstB.Fields(i).Value
       Next
      rst2.Update
   rstB.MoveNext 'move to next record
   Loop
   rstB.MoveFirst 'reset record pointer to the first record
   rst2.Close
   
   Set rst2 = Nothing
   Set tbldef = Nothing
   Set dba = Nothing
   
   MsgBox "Sorted Data Saved in " & strTable
   
   TblCreate_Exit:
   Exit Sub
   
   TblCreate_Err:
   MsgBox Err & " : " & Err.Description, vbExclamation, "TblCreate()"
   Resume TblCreate_Exit
   
   End Sub
   
   

Egenskapen rstB deklareras som ett DAO.Recordset Object.

Genom Set Property Proceduren kan ett postuppsättningsobjekt skickas till klassen ClsRecUpdate Objekt.

Update() Subroutine accepterar nummer med tre kolumner (0 baserade kolumnnummer) som parametrar för att beräkna och uppdatera den tredje parameterkolumnen med produkten av den första kolumnen * andra kolumnen.

DataSort() subrutin Sorterar posterna i stigande ordning baserat på kolumnnumret som skickats som parameter.

Datatypen Sorteringskolumn måste vara nummer eller valuta eller sträng. Andra datatyper ignoreras.

En lista över posterna kommer att dumpas i felsökningsfönstret. Listan över fält kommer att begränsas till endast fem fält, om postkällan har fler än så ignoreras resten av fälten.

TblCreate() subrutinen kommer att sortera data, baserat på kolumnnumret som skickats som en parameter, och skapar en tabell med ett nytt namn. Parametern är valfri, om ett kolumnnummer inte skickas som en parameter kommer tabellen att sorteras på data i den första kolumnen om datatypen för kolumnen är en giltig typ. Det ursprungliga namnet på tabellen kommer att ändras och läggas till med strängen “_2” till det ursprungliga namnet. Om källtabellens namn är Tabell1 då blir det nya tabellnamnet Tabell1_2 .

Testprogrammet för ClsUpdate.

Låt oss testa ClsRecUpdate Klassobjekt med ett litet program.

Testprogramkoden ges nedan:

Public Sub DataProcess()
Dim db As DAO.Database
Dim rstA As DAO.Recordset

Dim R_Set As ClsRecUpdate
Set R_Set = New ClsRecUpdate

Set db = CurrentDb
Set rstA = db.OpenRecordset("Table1", dbOpenTable)

'send Recordset Object to Class Object
Set R_Set.REC = rstA

'Update Total Price Field
Call R_Set.Update(1, 2, 3) 'col3=col1 * col2

'Sort Ascending Order on UnitPrice column & Print in Debug Window
Call R_Set.DataSort(2)

'Create New Table Sorted on UnitPrice in Ascending Order
Call R_Set.TblCreate(2) 
Set rstA = Nothing
Set db = Nothing
xyz:
End Sub

Du kan skicka vilken postuppsättning som helst för att testa klassobjektet.

Du kan skicka valfri kolumnnummer för att uppdatera en viss kolumn. Kolumnnumren behöver inte nödvändigtvis vara konsekutiva nummer. Men den tredje kolumnnummerparametern är målkolumnen som ska uppdateras. Den första parametern multipliceras med den andra kolumnparametern för att komma fram till det resultatvärde som ska uppdateras. Du kan modifiera klassmodulkoden för att göra vilken annan operation du vill göra på bordet.

Valet av sorteringskolumns datatyp måste endast vara String, Numeric eller Currency Type. Andra typer ignoreras. Recordset-kolumnnumren är 0-baserade, vilket betyder att den första kolumnnumret är 0, den andra kolumnen är 1, och så vidare.

Lista över alla länkar om detta ämne.

1. MS-Access Class Module och VBA
2. MS-Access VBA Class Object Arrays
3. MS-Access basklass och härledda objekt
4. VBA-basklass och härledda objekt-2
5. Basklass- och härledda objektvarianter
6. Ms-Access Recordset och Class Module
7. Åtkomst till klassmoduler och omslagsklasser
8. Omvandling av omslagsklassfunktionalitet
9. Ms-Access och Collection Object Basics
10. Ms-Access Class Module och Collection Object
11. Tabellposter i samlingsobjekt och form
12. Grundläggande om ordbokobjekt
13. Dictionary Object Basics-2
14. Sortera ordboksobjektnycklar och objekt
15. Visa poster från ordbok till formulär
16. Lägg till klassobjekt som ordboksobjekt
17. Uppdatera Class Object Dictionary-objekt på formulär