データ書き込みは
Call ADO_会社情報_書
データ読み込みは
Call ADO_会社情報_読
■Module0(設定用モジュール)
'ADO
Public Const Prv_Jet40 = "Provider=Microsoft.Jet.OLEDB.4.0;"
'Access DB
Public Const AccDB = "zmc.mdb"
■Module1
Option Explicit
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Sub ADO_会社情報_読()
Call ADO_基本(1)
End Sub
Sub ADO_会社情報_書()
Call ADO_基本(2)
End Sub
Sub ADO_基本(myNo As Long)
Dim strProvider As String, strDataSource As String
Dim myPath As String
On Error GoTo ErrCheck
'カレントフォルダへのパスの初期化
myPath = ThisWorkbook.Path
ChDrive myPath
ChDir myPath
Set CN = New ADODB.Connection
strDataSource = "Data Source=" & myPath & "\" & AccDB
strProvider = Prv_Jet40 & strDataSource
With CN
.ConnectionString = strProvider
.Open
End With
Select Case myNo
Case 1
Call ADO_1
Case 2
Call ADO_2
End Select
'-------------------
'レコードセットとDBコネクションを閉じ、オブジェクト破棄
DB_Close:
RS.Close: CN.Close
Set RS = Nothing: Set CN = Nothing
Exit Sub
ErrCheck:
MsgBox Err.Description
Resume DB_Close
End Sub
Sub ADO_1()
'DBからレコードを取り出す
Set RS = New ADODB.Recordset
With RS
'テーブルでもクエリでも同じように取り出せる
.Source = "SELECT * FROM tbl会社情報;"
.ActiveConnection = CN
.Open
End With
'-------------------
If Not (RS.EOF And RS.BOF) Then
'レコードをシートに転記
With Sheets(shtSet)
.Range("C2").Value = RS("社名")
.Range("C4").Value = RS("自年号")
.Range("D4").Value = RS("自年")
.Range("F4").Value = RS("自月")
.Range("H4").Value = RS("自日")
.Range("C5").Value = RS("至年号")
.Range("D5").Value = RS("至年")
.Range("F5").Value = RS("至月")
.Range("H5").Value = RS("至日")
.Range("C7").Value = RS("業種")
End With
End If
End Sub
Sub ADO_2()
'DBのレコードを変更書込みする(新規の場合はAddNewする)
Set RS = New ADODB.Recordset
With RS
'テーブルでもクエリでも同じように取り出せる
.Source = "SELECT * FROM tbl会社情報;"
.ActiveConnection = CN
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
'-------------------
If RS.EOF And RS.BOF Then RS.AddNew
'レコードをシートに転記
With Sheets(shtSet)
RS("社名") = .Range("C2").Value
RS("自年号") = .Range("C4").Value
RS("自年") = .Range("D4").Value
RS("自月") = .Range("F4").Value
RS("自日") = .Range("H4").Value
RS("至年号") = .Range("C5").Value
RS("至年") = .Range("D5").Value
RS("至月") = .Range("F5").Value
RS("至日") = .Range("H5").Value
RS("業種") = .Range("C7").Value
End With
RS.Update