MS-Accessレコードセットおよびクラスモジュール

はじめに。

ここでは、データ処理タスク用のクラスモジュール DAO.Recordsetを作成します。 オブジェクトはカスタムクラスオブジェクトに渡されます。カスタムクラスに渡されるのはオブジェクトなので、セットが必要です。 および取得 オブジェクトまたはそのプロパティ値を割り当てて取得するためのプロパティプロシージャペア。

小さなテーブルがあります： Table1 、レコードがほとんどありません。これが表1の画像です。

上記の表には、Desc、Qty、UnitPrice、およびTotalPriceの4つのフィールドしかありません。 TotalPriceフィールドは空です。

• クラスモジュールのタスクの1つは、TotalPriceフィールドをQty*UnitPriceの積で更新することです。
• クラスモジュールには、ユーザー指定のフィールドでデータを並べ替えるサブルーチンがあり、デバッグウィンドウにリストをダンプします。
• 別のサブルーチンは、パラメーターとして指定された列番号に基づいてデータを並べ替えた後、新しい名前でテーブルのコピーを作成します。

ClsRecUpdateクラスモジュール。

1. アクセスデータベースを開き、VBAウィンドウを開きます。
2. クラスモジュールを挿入します。
3. Nameプロパティ値をClsRecUpdateに変更します 。
4. 次のコードをコピーしてクラスモジュールに貼り付け、モジュールを保存します。
   

   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
   
   

rstBプロパティはDAO.Recordsetオブジェクトとして宣言されています。

プロパティの設定プロシージャを使用して、レコードセットオブジェクトをクラス ClsRecUpdateに渡すことができます。 オブジェクト。

Update（） サブルーチンは、3列の数値（0ベースの列番号）をパラメーターとして受け入れ、3番目のパラメーター列を計算して最初の列*2番目の列の積で更新します。

DataSort（） サブルーチンパラメーターとして渡された列番号に基づいて、レコードを昇順でソートします。

並べ替え列のデータ型は、数値、通貨、または文字列である必要があります。他のデータ型は無視されます。

レコードのリストは、デバッグウィンドウにダンプされます。フィールドのリストは5つのフィールドのみに制限され、レコードソースにそれ以上ある場合、残りのフィールドは無視されます。

TblCreate（） サブルーチンは、パラメーターとして渡された列番号に基づいてデータをソートし、新しい名前でテーブルを作成します。パラメータはオプションです。列番号がパラメータとして渡されない場合、列のデータ型が有効な型であれば、テーブルは最初の列のデータでソートされます。テーブルの元の名前が変更され、文字列“ _ 2”で追加されます 元の名前に。ソーステーブル名がTable1の場合 その場合、新しいテーブル名は Table1_2になります 。

ClsUpdateのテストプログラム。

ClsRecUpdateをテストしてみましょう 小さなプログラムでオブジェクトをクラス化します。

テストプログラムのコードを以下に示します。

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

クラスオブジェクトをテストするために、任意のレコードセットに合格できます。

特定の列を更新するために、任意の列番号を渡すことができます。列番号は必ずしも連続番号である必要はありません。ただし、3番目の列番号パラメーターは更新するターゲット列です。最初のパラメーターに2番目の列パラメーターを掛けて、更新する結果値を取得します。クラスモジュールコードを変更して、テーブルで実行したい他の操作を実行できます。

ソート列のデータ型の選択は、文字列、数値、または通貨タイプのみである必要があります。他のタイプは無視されます。レコードセットの列番号は0に基づいています。つまり、最初の列番号は0、2番目の列は1というようになります。

このトピックのすべてのリンクのリスト。

1. MS-AccessクラスモジュールとVBA
2. MS-AccessVBAクラスオブジェクト配列
3. MS-Accessの基本クラスと派生オブジェクト
4. VBA基本クラスと派生オブジェクト-2
5. 基本クラスと派生オブジェクトのバリアント
6. Ms-Accessレコードセットとクラスモジュール
7. アクセスクラスモジュールとラッパークラス
8. ラッパークラスの機能変換
9. Ms-Accessおよびコレクションオブジェクトの基本
10. Ms-Accessクラスモジュールとコレクションオブジェクト
11. コレクションオブジェクトとフォームのテーブルレコード
12. 辞書オブジェクトの基本
13. 辞書オブジェクトの基本-2
14. 辞書オブジェクトのキーとアイテムの並べ替え
15. 辞書からフォームへのレコードの表示
16. クラスオブジェクトをディクショナリアイテムとして追加
17. フォームのクラスオブジェクトディクショナリアイテムを更新する