AccessアクセスClassをVBAに移植してみた～Class本体～

けっこー大変だったorz
書式を直すだけなら、ふつーに正規表現とかでぱたぱたと出来たのだけど、
なにしろボクはVBAのお約束を知らない。
参照渡しをSetにするとかゆーのは、あちこちで見かけたので問題なかったのだけど、
まさか、引数を渡すのに括弧つけちゃダメな言語があったとはっ！と…
あとアレだ。Class内部のコーディングのミスを、
呼び出し側のPropertyの設定ミスとしてエラー吐くのはどうよ。
そこカプセル化しちゃダメだよね？てなトコロ。
Openさせたときにエラー吐かせて拾おうとしたら、
Class内部でのエラー回避処理には引っかからず、
Open Method読んでるトコでエラー吐くし。内部でのチェック意味ねー( ﾟ-ﾟ)~ﾟ

仕上がりはけっこーおざなり。
とりあえず動いたからいいや的な作りなので、丸写しで追求しないか、
使いやすいようカスタマイズしてください( ﾟ-ﾟ)~ﾟ

参考：AccessアクセスClassをVBAに移植してみた～呼び出し側～


(Class Module : SetDBtoTable )

Option Explicit
'指定したDBを読み込み、テーブルで返す。
'----------
'Variable
'----------
Private m_Provider As String
Private m_DataSource As String
Private m_ConnectionString As String
Private m_UserID As String
Private m_Password As String
Private m_RecordCount As Integer
Private m_ColumnCount As Integer
Private m_DataTable() As String  'テーブルデータ格納場所
Private cn As ADODB.Connection
Private rs As ADODB.Recordset
'----------
'Property
'----------
'------------------------------
'DBへアクセスするために必要なProperty群
'------------------------------
'プロバイダ指定。Accessなら"Microsoft.Jet.OLEDB.4.0;"みたいなの
Property Get Provider() As String
  Provider = m_Provider
End Property
Property Let Provider(Provider As String)
  m_Provider = Provider
End Property
'データソース指定。Accessならファイル名
Property Get DataSource() As String
  DataSource = m_DataSource
End Property
Property Let DataSource(DataSource As String)
  m_DataSource = DataSource
End Property
'コネクションストリング。テーブル名だったりSQLだったり
Property Get ConnectionString() As String
  ConnectionString = m_ConnectionString
End Property
Property Let ConnectionString(ConnectionString As String)
  m_ConnectionString = ConnectionString
End Property
'ユーザーID。テストしてないから動くかどうかわからない( ﾟ-ﾟ)~ﾟ
Property Get UserID() As String
  UserID = m_UserID
End Property
Property Let UserID(UserID As String)
  m_UserID = UserID
End Property
'パスワード。テストしてな（以下略
Property Get Password() As String
  Password = m_Password
End Property
  Property Let Password(Password As String)
m_Password = Password
End Property
'------------------------------
'得たデータを参照するProperty群
'------------------------------
'レコード数
Property Get RecordCount() As Long
  RecordCount = m_RecordCount
End Property
'カラム数
Property Get ColumnCount() As Long
  ColumnCount = m_ColumnCount
End Property
'Value Override群 Start…って思ったら、Overrideできないでやんの( ﾟ-ﾟ)~ﾟ
Property Get Value() As String()
  Value = m_DataTable
End Property
'Item Override群 Start Default Property指定。Default指定もできないでやんの
Property Get Item(ByVal i As Integer, ByVal j As Integer) As String
  Item = m_DataTable(i, j)
End Property
Property Get Record(ByVal i As Integer) As String()
  Record = m_Record(i)
End Property
Property Get Column(ByVal j As Integer) As String()
  Column = m_Column(j)
End Property
'----------
'Constructor
'----------
Private Sub Class_Initialize()
  Debug.Print ("Constructor:" & TypeName(Me))
  m_Provider = "Microsoft.Jet.OLEDB.4.0;"
End Sub
'----------
'Destructor
'----------
Private Sub Class_Terminate()
  Debug.Print ("Destructor:" & TypeName(Me))
End Sub
'----------
'Method
'----------
'DBにアクセスし、レコード数、カラム数、データ本体を読み込み、Class変数に代入
Public Function OpenDB() As Boolean
  Dim OnOK As Boolean
  OnOK = True
  Set cn = New ADODB.Connection
  Set rs = New ADODB.Recordset
  Dim i As Integer
  Dim j As Integer
  cn.Provider = m_Provider
  '_ConnectionStringが空か確認。空であればエラーを吐きFalseを返してMethod終了
  If m_ConnectionString = "" Then
    Debug.Print ("ERROR:" & TypeName(Me) & ":ConnectionString Property Not Assignment")
    OnOK = False
    OpenDB = OnOK
  End If
  'DataSourceが空か確認。空であればエラーを吐きFalseを返してMethod終了
  If m_DataSource = "" Then
    Debug.Print ("ERROR:" & TypeName(Me) & ":DataSource Property Not Assignment")
    OnOK = False
    OpenDB = OnOK
    Exit Function
  End If
  'DataSource設定
  cn.Properties("Data Source").Value = m_DataSource
  'ID/Passwd設定（試してない
  If m_UserID <> "" Then
    cn.Properties("UserID").Value = m_UserID
  End If
  If m_Password <> "" Then
    cn.Properties("Password").Value = m_Password
  End If
On Error GoTo Error_Handler
  cn.Open
'ConnectionString(テーブ名やSQL。DELETEとか書かれても、
'rs.open()のときにReadOnlyで開くからはじけると思う
  rs.Source = m_ConnectionString
  rs.ActiveConnection = cn
  rs.CursorType = ADODB.CursorTypeEnum.adOpenKeyset
  rs.LockType = ADODB.LockTypeEnum.adLockReadOnly
  rs.Open
  m_RecordCount = rs.RecordCount
  m_ColumnCount = rs.Fields.Count
  ReDim m_DataTable(m_RecordCount - 1, m_ColumnCount - 1)
  i = 0
  Do Until rs.EOF
    For j = 0 To m_ColumnCount - 1
      m_DataTable(i, j) = rs.Fields(j).Value
    Next j
    rs.MoveNext
    i = i + 1
  Loop
  OpenDB = OnOK
  Exit Function
  
Error_Handler:
  'Try中のエラーのとき cnとrsのopen、データ取り込み時それぞれで節を分ければError位置が特定できる。はず。
  Debug.Print ("ERROR:" & TypeName(Me) & ":DB or RS Open failed")
  OnOK = False
Error_Handler_End:
  OpenDB = OnOK
End Function
'クローズ。ホントは必要なさそうなんだけど、OpenしたからにはCloseしたくなるのは本能。
'VBAはちゃんとデストラクタくんが動いてくれるのでcallはしない。。
Public Sub CloseDB()
  rs.Close
  cn.Close
  Erase m_DataTable
End Sub
Public Sub putData()
  rs.MoveFirst
  ActiveCell.CopyFromRecordset rs
End Sub
Public Sub putRange(Arg_Range As String, Optional Worksheet As String)
  rs.MoveFirst
  If Worksheet = vbNullString Then
    ActiveSheet.Range(Arg_Range).CopyFromRecordset rs
  Else
    Worksheets(Worksheet).Range(Arg_Range).CopyFromRecordset rs
  End If
End Sub
Public Sub putCells(ByVal Row As Integer, ByVal Col As Integer, Optional ByVal Worksheet As String)
  rs.MoveFirst
  If Worksheet = vbNullString Then
    ActiveSheet.Cells(Row, Col).CopyFromRecordset rs
  Else
    Worksheets(Worksheet).Cells(Row, Col).CopyFromRecordset rs
  
  End If
End Sub
'----------
'Private Function
'----------
'データ要素単体渡し。stringで返す。範囲外のINDEX渡すと怒られるぞ。
Private Function m_Item(ByVal i As Integer, ByVal j As Integer) As String
  m_Item = m_DataTable(i, j)
End Function
'INDEXのRecordの要素全てを、Stringの１元配列型で返す。
Private Function m_Record(ByVal i As Integer) As String()
  Dim ReturnTable() As String
  Dim j As Integer
  ReDim ReturnTable(m_ColumnCount - 1)
  For j = 0 To m_ColumnCount - 1
    ReturnTable(j) = m_DataTable(i, j)
  Next j
  m_Record = ReturnTable
End Function
'INDEXのColumnの要素全てを、Stringの１元配列型で返す。
Private Function m_Column(ByVal j As Integer) As String()
  Dim ReturnTable() As String
  Dim i As Integer
  ReDim ReturnTable(m_RecordCount - 1)
  For i = 0 To m_RecordCount - 1
    ReturnTable(i) = m_DataTable(i, j)
  Next i
  m_Column = ReturnTable
End Function