2017
5
／
01
数年前に書いたこのシリーズのコード。もちろん間違ってはないし、きちんと動くものではあるのですが。でも、今ならもっとスマートなコードが書けるなと思って！ 自分の過去のコードの供養のためにも、リファクタリングしたものを書き残しておきます。
関連記事
- 第1回 Excelからデータベースへの接続
- 第2回 テーブル設計とシート&コードの準備
- 第3回 SQLを使った読み書きの処理
- 第4回 条件を絞ってデータを読み込む
- 第5回 レコードの更新・削除
- 第6回 トランザクション処理
- 番外 クラスで処理をまとめる ←NOW!
この連載がもっと実用的なサンプルで書籍になりました！
最近Excelでもクラスモジュールを使うようになってきまして。
こういう記事も書いているうちに、昔書いた、DBと連携させるコードに自分でモニョってきて書き直しました。
クラスを作ってDB関係の処理は全部そちらにおまかせ、標準モジュールに書く処理は最低限にしちゃおう！ という内容です。
タスクごとにDB接続/切断する場合
DataBase クラスモジュール
DBに接続したり処理したりする部分の実働部隊。新規クラスモジュールを作って、オブジェクト名をDataBaseとしています。
ファイル名とSQLを引数として受け取る形になっているので、このクラスを作っておいてインポートしちゃえばかなり汎用的につかえるんじゃないかなーと。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
'### DataBase クラス ### Private Connection As Object 'ADOコネクションオブジェクト Public Sub connectDB(FILE_NAME As String) 'DB接続 Set Connection = CreateObject("ADODB.Connection") 'ADOコネクションオブジェクトを作成 Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & FILE_NAME & ";" 'コネクションを開く End Sub Public Sub disconnectDB() 'DB切断 Connection.Close 'コネクションのクローズ Set Connection = Nothing End Sub Public Function getRecordSet(FILE_NAME As String, str_SQL As String, clear_range As Range, output_cell As Range) As Boolean 'レコードセットを出力する関数[SELECT文] Call connectDB(FILE_NAME) '接続 On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Dim RcdSet As Object 'ADOレコードセットオブジェクト Set RcdSet = CreateObject("ADODB.RecordSet") 'ADOレコードセットオブジェクトを作成 RcdSet.Open str_SQL, Connection '実行 clear_range.ClearContents '前のデータクリア If RcdSet Is Nothing Then 'レコードセットがなかったら GoTo Finally '終了処理へ End If If RcdSet.BOF = True And RcdSet.EOF = True Then '空だったら MsgBox "対象データがありません。" GoTo Finally '終了処理へ End If '出力方法1-スタートのセルを指定して一気に貼り付け output_cell.CopyFromRecordset RcdSet '出力方法2-ひとつひとつ貼り付け Dim row As Integer: row = output_cell.Row Dim col As Integer: col = output_cell.Column Dim field As Object, i As Integer Do Until RcdSet.EOF 'レコードセットが終了するまで処理を繰り返す i = 0 For Each field In RcdSet.Fields 'フィールドの数だけ繰り返す Cells(row, col + i) = RcdSet(field.Name) i = i + 1 Next row = row + 1 '行をカウントアップする RcdSet.MoveNext '次のレコードに移動する Loop getRecordSet = True '成功 GoTo Finally Err_Handler: 'エラー処理 Set RcdSet = Nothing MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ Finally: '終了処理 If Not RcdSet Is Nothing Then 'レコードセットオブジェクトがあったら RcdSet.Close 'レコードセットのクローズ Set RcdSet = Nothing End If Call disconnectDB 'DB切断 End Function Public Function executeSingleSQL(FILE_NAME As String, str_SQL As String) As Boolean '1つのSQL文（String型）を処理する関数[INSERT/UPDATE/DELETE文] Call connectDB(FILE_NAME) '接続 On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Connection.BeginTrans 'トランザクション開始 Connection.Execute str_SQL '実行 Connection.CommitTrans 'トランザクション終了（確定処理） executeSingleSQL = True '成功 GoTo Finally Err_Handler: 'エラー処理 Connection.RollbackTrans 'ロールバック MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ Finally: '終了処理 Call disconnectDB '切断 End Function Public Function executeMultiSQL(FILE_NAME As String, list_SQL As Collection) As Boolean '1つ以上のSQL文リスト（Collection型）を処理する関数[INSERT/UPDATE/DELETE文] Call connectDB(FILE_NAME) '接続 On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Connection.BeginTrans 'トランザクション開始 Dim strSQL As Variant For Each strSQL In list_SQL 'Collectionをループ Connection.Execute strSQL '実行 Next Connection.CommitTrans 'トランザクション終了（確定処理） executeMultiSQL = True '成功 GoTo Finally Err_Handler: 'エラー処理 Connection.RollbackTrans 'ロールバック MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ Finally: '終了処理 Call disconnectDB '切断 End Function |
4行目と11行目から始まってるのが接続・切断するプロシージャ。
17行目から始まってるのが、ファイル名、SELECT文、クリア範囲、出力基点セルを受け取ってレコードセットを出力する関数。出力方法1のほうが1行で済んで楽ですが、書式設定が消えちゃうことがあるので、それが嫌な場合は方法2のほうがおすすめ。使うときはどちらかコメントアウトしてくださいね。
69行目と90行目から始まってるのが、INSERT/UPDATE/DELETE文を処理する関数ですが、前者が「1つのSQL文（String型）」、後者は「1つ以上のSQL文リスト（Collection型）」を受け取って処理します。後者は、持ってきた複数の文の中に1つでもエラーが起こると全部なかったことになるので、よりトランザクションのありがたみがわかります。
Module1 標準モジュール
DataBaseクラスを利用する側の記述です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
'### Module1 ### Private Const FILE_NAME As String = "C:\test.accdb" 'ファイル名 Sub selectTask() 'SELECT文を使ってレコードセットをセルに出力 Dim strSQL As String strSQL = "SELECT文" Dim clearRange As Range Set clearRange = ActiveSheet.Range("A1:C100") 'クリア範囲 Dim outputCell As Range Set outputCell = ActiveSheet.Range("A1") '出力基点セル Dim db As DataBase Set db = New DataBase 'インスタンス生成 If db.getRecordSet(FILE_NAME, strSQL, clearRange, outputCell) = True Then MsgBox "正常に終了しました" End If End Sub Sub executeSingleTask() '1つのSQL文（String型）の実行 Dim strSQL As String strSQL = "INSERT/UPDATE/DELETE文" Dim db As DataBase Set db = New DataBase 'インスタンス生成 If db.executeSingleSQL(FILE_NAME, strSQL) = True Then 'SQL文を実行 MsgBox "正常に終了しました" End If End Sub Sub executeMultiSQL() '1つ以上のSQL文リスト（Collection型）の実行 Dim listSQL As Collection Set listSQL = New Collection 'コレクション生成 listSQL.Add "INSERT/UPDATE/DELETE文1" listSQL.Add "INSERT/UPDATE/DELETE文2" listSQL.Add "INSERT/UPDATE/DELETE文3" Dim db As DataBase Set db = New DataBase 'インスタンス生成 If db.executeMultiSQL(FILE_NAME, listSQL) = True Then 'SQL文リストを実行 MsgBox "正常に終了しました" End If End Sub |
宣言セクションで、ファイル名をPrivateの定数としておけば便利。
4行目から始まってるのが、SELECT文で抽出したいとき。さきほど作ったクラスのインスタンスを作って、クラスのdb.getRecordSet関数へファイル名、SELECT文、クリア範囲と出力基点のセルを投げて（16行目）、接続・実行・切断までをおまかせしちゃいます。その結果のみをTrue/Falseで受け取るので、こっちの記述は超スッキリ！！！
21行目から始まってるのが、INSERT/UPDATE/DELETE文を実行したいとき。インスタンスを作って、クラスのdb.executeSingleSQL関数へ単一のINSERT/UPDATE/DELETE文を投げています（29行目）。
34行目から始まってるのは、複数のINSERT/UPDATE/DELETE文を一度に実行したいとき。Collection型のSQL文を用意して、db.executeMultiSQL関数へ投げています（45行目）。
DB接続/切断を頻繁にやりたくない場合
更になんですが、今まで書いてきたのって、1回の読込、書込ごとにいちいち同じDBに接続、切断、ということをしてたんですよね。それを最小限にしたいなー、っていう場合。
UserFormを使って、開くときに接続して閉じるときに切断すれば、Formが開いてる間は接続が保持されるので、なんかスマートなんじゃね？ って考えたら、こうなりました。
DataBase クラスモジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
'### DataBase クラス ### Private Connection As Object 'ADOコネクションオブジェクト Public Sub connectDB(FILE_NAME As String) 'DB接続 Set Connection = CreateObject("ADODB.Connection") 'ADOコネクションオブジェクトを作成 Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & FILE_NAME & ";" 'コネクションを開く End Sub Public Sub disconnectDB() 'DB切断 Connection.Close 'コネクションのクローズ Set Connection = Nothing End Sub Public Function getRecordSet(str_SQL As String, clear_range As Range, output_cell As Range) As Boolean 'レコードセットを出力する関数[SELECT文] On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Dim RcdSet As Object 'ADOレコードセットオブジェクト Set RcdSet = CreateObject("ADODB.RecordSet") 'ADOレコードセットオブジェクトを作成 RcdSet.Open str_SQL, Connection '実行 clear_range.ClearContents '前のデータクリア If RcdSet Is Nothing Then 'レコードセットがなかったら Exit Function End If If RcdSet.BOF = True And RcdSet.EOF = True Then '空だったら MsgBox "対象データがありません。" GoTo Finally '終了処理へ End If '出力方法1-スタートのセルを指定して一気に貼り付け output_cell.CopyFromRecordset RcdSet '出力方法2-ひとつひとつ貼り付け Dim row As Integer: row = output_cell.Row Dim col As Integer: col = output_cell.Column Dim field As Object, i As Integer Do Until RcdSet.EOF 'レコードセットが終了するまで処理を繰り返す i = 0 For Each field In RcdSet.Fields 'フィールドの数だけ繰り返す Cells(row, col + i) = RcdSet(field.Name) i = i + 1 Next row = row + 1 '行をカウントアップする RcdSet.MoveNext '次のレコードに移動する Loop Set RcdSet = Nothing getRecordSet = True '成功 GoTo Finally Err_Handler: 'エラー処理 Set RcdSet = Nothing MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ Finally: '終了処理 If Not RcdSet Is Nothing Then 'レコードセットオブジェクトがあったら RcdSet.Close 'レコードセットのクローズ Set RcdSet = Nothing End If End Function Public Function executeSingleSQL(str_SQL As String) As Boolean '1つのSQL文（String型）を処理する関数[INSERT/UPDATE/DELETE文] On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Connection.BeginTrans 'トランザクション開始 Connection.Execute str_SQL '実行 Connection.CommitTrans 'トランザクション終了（確定処理） executeSingleSQL = True '成功 Exit Function Err_Handler: 'エラー処理 Connection.RollbackTrans 'ロールバック MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ End Function Public Function executeMultiSQL(list_SQL As Collection) As Boolean '1つ以上のSQL文リスト（Collection型）を処理する関数[INSERT/UPDATE/DELETE文] On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Connection.BeginTrans 'トランザクション開始 Dim strSQL As Variant For Each strSQL In list_SQL 'Collectionをループ Connection.Execute strSQL '実行 Next Connection.CommitTrans 'トランザクション終了（確定処理） executeMultiSQL = True '成功 Exit Function Err_Handler: 'エラー処理 Connection.RollbackTrans 'ロールバック MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ End Function |
上に書いたのとだいたい一緒なんですが、下3つのプロシージャの中にあった、接続・切断の呼び出しがなくなりました。引数も減っています。
Module1 標準モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
'### Module1 ### Private Const FILE_NAME As String = "C:\test.accdb" 'ファイル名 Private db As DataBase 'インスタンス変数 Sub showForm() UserForm1.Show 'Formを開く End Sub Sub connectTask() 'DB接続 Set db = New DataBase 'インスタンス生成 Call db.connectDB(FILE_NAME) '接続 End Sub Sub disconnectTask() 'DB切断 Call db.disconnectDB '切断 Set db = Nothing End Sub Sub selectTask() 'SELECT文を使ってレコードセットをセルに出力 Dim strSQL As String strSQL = "SELECT文" Dim clearRange As Range Set clearRange = ActiveSheet.Range("A1:C100") 'クリア範囲 Dim outputCell As Range Set outputCell = ActiveSheet.Range("A1") '出力基点セル If db.getRecordSet(strSQL, clearRange, outputCell) = True Then MsgBox "正常に終了しました" End If End Sub Sub executeSingleTask() '1つのSQL文（String型）の実行 Dim strSQL As String strSQL = "INSERT/UPDATE/DELETE文" If db.executeSingleSQL(strSQL) = True Then 'SQL文を実行 MsgBox "正常に終了しました" End If End Sub Sub executeMultiTask() '1つ以上のSQL文リスト（Collection型）の実行 Dim listSQL As Collection Set listSQL = New Collection 'コレクション生成 listSQL.Add "INSERT/UPDATE/DELETE文1" listSQL.Add "INSERT/UPDATE/DELETE文2" listSQL.Add "INSERT/UPDATE/DELETE文3" If db.executeMultiSQL(listSQL) = True Then 'SQL文リストを実行 MsgBox "正常に終了しました" End If End Sub |
宣言セクションで、ファイル名と一緒にクラス用のインスタンス変数を Private 宣言しておけば、このモジュール全体で使えます。インスタンス生成してDB接続するプロシージャと、切断のプロシージャをここで書いておきます（9～17行目）。
他はだいたい一緒ですが、下3つのプロシージャではインスタンスを生成する必要がなくなりました。
showFormプロシージャにて、Form を開くことがトリガーになります。
UserForm1 フォームモジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
'### UserForm1 ### Private Sub UserForm_Initialize() 'フォームが開くとき Call connectTask 'DB接続 End Sub Private Sub UserForm_Terminate() 'フォームが閉じるとき Call disconnectTask 'DB切断 End Sub Private Sub CommandButton1_Click() Call selectTask 'SELECT文を使ってレコードセットをセルに出力 End Sub Private Sub CommandButton2_Click() Call executeSingleTask '1つのSQL文（String型）の実行 End Sub Private Sub CommandButton3_Click() Call executeMultiTask '1つ以上のSQL文リスト（Collection型）の実行 End Sub |
こう書いておけば、フォームが開くときに接続、閉じるときに切断してくれます。ボタンが3つあるとして、そのボタンから標準モジュールのプロシージャを呼び出せば、ボタンクリックで読込・書込ができます。
これなら接続・切断は1度きりで、いろいろ処理できるからスマートなんじゃないかなー。
以上です！ いつも記事にするときには、そのときの自分の中のベストで書いているつもりなんですが、数年経つとモニョりますねw 成長できてるということかな…。。
追記：標準モジュールでレコードセットだけ返す
わざわざインスタンス作らなくてもいいから！ クラスじゃなくて良いし、なんなら書き込みもしないから、読み込みだけ効率よくレコードセットで欲しいんだよ！！！ という状況に遭遇したのでそれも書いておきます。
DataBase 標準モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
Private Connection As Object 'ADOコネクションオブジェクト Sub connectDB(FILE_NAME As String) 'DB接続 Set Connection = CreateObject("ADODB.Connection") 'ADOコネクションオブジェクトを作成 Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & FILE_NAME & ";" 'コネクションを開く End Sub Sub disconnectDB() 'DB切断 Connection.Close 'コネクションのクローズ Set Connection = Nothing End Sub Function getRecordSet(str_SQL As String) As Recordset 'レコードセットを返す関数[SELECT文] On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ Dim rcdSet As Object 'ADOレコードセットオブジェクト Set rcdSet = CreateObject("ADODB.RecordSet") 'ADOレコードセットオブジェクトを作成 rcdSet.Open str_SQL, Connection '実行 If rcdSet Is Nothing Then 'レコードセットがなかったら Exit Function End If If rcdSet.BOF = True And rcdSet.EOF = True Then '空だったら Set rcdSet = Nothing Exit Function End If Set getRecordSet = rcdSet '成功 Exit Function Err_Handler: 'エラー処理 Set rcdSet = Nothing MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description 'エラーメッセージ End Function |
シートに吐き出すんじゃなくて、返り値の型をレコードセットにしちゃう。
Module1 標準モジュール
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
Private Const FILE_NAME As String = "C:\test.accdb" 'ファイル名 Sub runTask() Call connectDB(FILE_NAME) '接続 Dim obj As Object For Each obj In objList 'なにかのリストをループさせるとか Dim strSQL As String: strSQL = strSQL = "SELECT文" 'ループによって違うSQL文 Dim rcdSet As Object 'ADOレコードセットオブジェクト作成 Set rcdSet = getRecordSet(strSQL) 'レコードセット取得 If rcdSet Is Nothing Then GoTo SkipLine 'レコードセットがなかったらジャンプ Do Until rcdSet.EOF 'レコードセットが終了するまで処理を繰り返す 'rcdSet!フィールド名 を使っていろいろ処理 rcdSet.MoveNext '次のレコードに移動する Loop '終了処理 rcdSet.Close 'レコードセットのクローズ Set rcdSet = Nothing SkipLine: 'レコードセットがなかったらここへ飛ぶ Next Call disconnectDB 'DB切断 End Sub |
読み取り専用で、欲しいデータだけとってきてグラフにしたいとか、そういう目的ならこっちのほうが便利かも。
ExcelVBAに興味をお持ちの方は、こちらの記事もどうぞ！
- これからExcelのマクロを始めたいという方に！簡単な練習問題作りました。
- 私がExcelVBAでよく使う便利なコード・スニペットまとめ
- プログラム初心者さんへ贈る、エラーが起きたら試してみて欲しいこと
- ExcelVBAのクラスモジュールって何？という人向けの使い方まとめ
書籍を執筆しています。
- Tweet
-
-
635
公開日：2017/05/01
更新日：2017/06/26
関連記事
ExcelVBAによるExcelからPDFへの変換
ExcelVBA入門第8回 繰り返し処理
ExcelVBAでControlオブジェクトのChangeイベントを一括制御する方法
ExcelVBAでクラスモジュールを活用してCSVファイルをコレクションに格納する「MS Office」の月間人気記事
ExcelVBAとAccessの連携 第1回 Excelからデータベースへの接続
ExcelVBAのクラスモジュールって何？という人向けの使い方まとめ
これからExcelのマクロを始めたいという方に！簡単な練習問題作りました。
Excel2013で、折れ線グラフが原点から始まるパレート図の作り方
ExcelVBAでカレンダーコントロールを自作する他カテゴリの月間人気記事
初心者でも、“デキる奴”と思わせるプレゼンテーションの基本とコツ
私がIllustratorで絵を描けるようになるのに有効だった練習方法
産む前は知らなかったけど、出産後の入院生活が地味に結構キツかったよなーという思い出
初心者向け、Illustratorで簡単な図形やイラストを描くチュートリアル
日本の伝統色の組み合わせ、襲色目（かさねいろめ）の色コードまとめ*印は必須項目です。コメントは承認制ですので、反映までしばらくお待ち下さい。（稀にですがスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。）
コメントを残す