[VBA] クラスを利用するメリットと方法について & 簡単なサンプル（２）
概要
この記事について
この記事は、
[VBA] クラスを利用するメリットと方法について & 簡単なサンプル（１）の続きの記事。
（１）とは違ったサンプルを用いて、前回とは違ったクラスの利用方法やそのメリットを記したい。
TableCreaterの例だと、カプセル化の恩恵や初期化処理・終了処理を必ず実行できることの恩恵が十分には表現できなかったように思えるため、
本記事のサンプル（clsCreateNewExcel）でそれらを表現しようと思う。
説明のために作成したAccessファイルとソースコードはこちらでダウンロードできます。
作成環境
Windows10
MSOffice 2019
サンプルの概要
Accessファイルで、内部に商品テーブルを持つ。
次のような画面から、
ボタンにより異なった処理を呼び出し実行する。
いずれのボタンのイベントも、共通処理として、
- デスクトップに新しいExcelブックを作成する（ファイル名：Test-Excel-Class-日付時刻.xlsx）
を持つ。
個別の処理として、
- 商品テーブルから単価が１００００を超える商品のデータを抽出し、
作成したExcelブックのシートに転記する。 - 商品テーブルからコードがBから始まる商品のデータを抽出し、
作成したExcelブックのシートに転記する。 - WebAPIより商品データのJsonデータを取得し、
テーブル形式にパースしたのち、Excelブックのシートに転記する。
を持つ。
Excelブック作成とブック関連オブジェクトの管理のために、
clsCreateNewExcelクラス
というクラスモジュールを作成した。
clsCreateNewExcelクラス
役割
clsCreateNewExcelクラスは新規Excelアプリケーションのインタフェースと新規Excelブックを生成し、
それぞれのオブジェクトを取得することを許す。
また、呼び出されるたびにブックにワークシートを追加する関数を持つ。
コード
1'@Folder("class")
2Option Compare Database
3Option Explicit
4
5'**************************
6'*Excelブック作成クラス
7'**************************
8
9'定数
10
11'変数
12Private currentSheetNum As Long
13Private myXlApp As Object
14Private myWorkBook As Object
15Private dicWorkSheet As Dictionary
16
17
18'******************************************************************************************
19'*getter/setter
20'******************************************************************************************
21Public Property Get xlApplication() As Object
22 Set xlApplication = myXlApp
23End Property
24
25
26Public Property Get Workbook() As Object
27 Set Workbook = myWorkBook
28End Property
29
30
31Public Property Get WorkSheets(ByVal num As Long) As Object
32 If Not dicWorkSheet.Exists(num) Then Call MsgBox("シートがありません。", vbExclamation, TOOL_NAME): Set WorkSheets = Nothing: Exit Property
33 Set WorkSheets = dicWorkSheet.Item(num)
34End Property
35
36
37'******************************************************************************************
38'*関数名 ：Class_Initialize
39'*機能 ：
40'*引数 ：
41'******************************************************************************************
42Private Sub Class_Initialize()
43
44 '定数
45 Const FUNC_NAME As String = "Class_Initialize"
46
47 '変数
48
49 On Error GoTo ErrorHandler
50
51 'シート数の設定
52 currentSheetNum = 1
53
54 'オブジェクトの設定
55 Set myXlApp = CreateObject("Excel.Application")
56 With myXlApp
57 'バックグラウンドで生成・編集
58 .Visible = False
59 .ScreenUpdating = False
60 .DisplayAlerts = False
61 End With
62 Set myWorkBook = myXlApp.Workbooks.Add
63 Set dicWorkSheet = New Dictionary
64 dicWorkSheet.Add currentSheetNum, myWorkBook.WorkSheets(currentSheetNum)
65
66ExitHandler:
67
68 Exit Sub
69
70ErrorHandler:
71
72 MsgBox "エラーが発生したため、マクロを終了します。" & _
73 vbLf & _
74 "関数名：" & FUNC_NAME & _
75 vbLf & _
76 "エラー番号：" & Err.Number & vbNewLine & _
77 Err.Description, vbCritical, TOOL_NAME
78
79 GoTo ExitHandler
80
81End Sub
82
83
84'******************************************************************************************
85'*関数名 ：Class_Terminate
86'*機能 ：
87'*引数 ：
88'******************************************************************************************
89Private Sub Class_Terminate()
90
91 '定数
92 Const FUNC_NAME As String = "Class_Terminate"
93
94 '変数
95
96 On Error GoTo ErrorHandler
97
98 'ブックの保存 To:=デスクトップ
99 With CreateObject("WScript.Shell")
100 myWorkBook.SaveAs .SpecialFolders("Desktop") & "\" & "Test-Excel-Class-" & Format(Now, "yyyymmddhhnnss") & ".xlsx"
101 End With
102
103 '設定のリストア
104 With myXlApp
105 .ScreenUpdating = True
106 .DisplayAlerts = True
107 End With
108
109 'クローズ
110 myWorkBook.Close
111 myXlApp.Quit
112
113ExitHandler:
114
115 Set dicWorkSheet = Nothing
116 Set myWorkBook = Nothing
117 Set myXlApp = Nothing
118
119 Exit Sub
120
121ErrorHandler:
122
123 MsgBox "エラーが発生したため、マクロを終了します。" & _
124 vbLf & _
125 "関数名：" & FUNC_NAME & _
126 vbLf & _
127 "エラー番号：" & Err.Number & vbNewLine & _
128 Err.Description, vbCritical, TOOL_NAME
129
130 GoTo ExitHandler
131
132End Sub
133
134
135
136'******************************************************************************************
137'*関数名 ：addNewSheet
138'*機能 ：ブックにシートを追加
139'*引数 ：
140'*戻り値 ：追加されたシートオブジェクト
141'******************************************************************************************
142Public Function addNewSheet() As Object
143
144 '定数
145 Const FUNC_NAME As String = "addNewSheet"
146
147 '変数
148 Dim ws As Object
149
150 On Error GoTo ErrorHandler
151
152 Set addNewSheet = Nothing
153
154 currentSheetNum = currentSheetNum + 1
155 '最後尾にシート追加
156 Set ws = myWorkBook.WorkSheets.Add(After:=myWorkBook.WorkSheets(myWorkBook.WorkSheets.Count))
157 dicWorkSheet.Add currentSheetNum, ws
158
159 Set addNewSheet = ws
160
161ExitHandler:
162
163 Exit Function
164
165ErrorHandler:
166
167 MsgBox "エラーが発生したため、マクロを終了します。" & _
168 vbLf & _
169 "関数名：" & FUNC_NAME & _
170 vbLf & _
171 "エラー番号：" & Err.Number & vbNewLine & _
172 Err.Description, vbCritical, TOOL_NAME
173
174 GoTo ExitHandler
175
176End Function
177
178
179
カプセル化
上記のコードを見るとわかるように、
クラス内部の変数myXlApp、myWorkBookなどはPrivateのスコープで宣言されている。
そのため、
各種Property Getを通してのみ取得可能であり、
直接値を参照して取得したり設定したりすることはできない。
唯一、dicWorkSheet（ワークシートが格納されているDictionaryオブジェクト）は、
関数addNewSheetを通してのみDicitonaryのKey&Valueペアの設定が可能である。
その動作すらも、「最後尾にシートを追加する」という定型的な動作以外は許されていない。
このように、クラス内部の変数が特定の方法以外で値の設定ができないように守られていることを カプセル化 と呼ぶ。
カプセル化により、クラスの変数が不正に設定されたり削除されたりすることを防ぎ、バグの発生を防いだり、コードの見通しを良くしたりする。
初期化処理・終了処理
こちらも上記のコードを見るとわかるように、
Class_Initializeにおいて、クラスのオブジェクトを生成した際に
最低限やりたい処理をまとめて行うことができるようになっている。
最低限やりたい処理とは、
新規Excelアプリケーションのインタフェースの生成、
新規Excelブックの生成、
ブックの最初のワークシートをDictionaryに格納すること、
Excelアプリケーションの動作をバックグラウンドにし、画面更新を停止し、警告アラートを抑制することである。
Class_Terminateは逆に、
Excelアプリケーションの設定のリストアを行い、
ブックをクローズし、Excelアプリケーションを終了させる。
また、PCのデスクトップにブックを保存させる。
このように、最低限やりたい処理をかならず実行するようにできているため、
わざわざ外部のコードで記述する必要もないし、
見落としてコーディングし忘れたりする恐れもなくなる。
特に、Excelアプリケーションのオブジェクトの場合、
オブジェクトを格納した変数がグローバル変数であり、かつ処理後にNothingが代入されなかった場合、
ずっとExcelがバックグラウンドで起動し続けることになる
ため、注意が必要。
その他のコード
getTableHeader
引数で指定したテーブルのヘッダー文字列配列を、
値返却用の変数に格納して呼び出し元に返す。
1'******************************************************************************************
2'*関数名 ：getTableHeader
3'*機能 ：テーブルのヘッダー文字列配列を取得
4'*引数 ：テーブル名
5'*引数 ：結果返却用
6'*戻り値 ：True > 正常終了、False > 異常終了
7'******************************************************************************************
8Public Function getTableHeader(ByVal tblName As String, ByRef pArrHeader() As String) As Boolean
9
10 '定数
11 Const FUNC_NAME As String = "getTableHeader"
12
13 '変数
14 Dim i As Long
15
16 On Error GoTo ErrorHandler
17
18 getTableHeader = False
19 Erase pArrHeader
20
21 With db.TableDefs(tblName)
22 ReDim pArrHeader(0 To .Fields.Count - 1)
23 For i = 0 To .Fields.Count - 1
24 pArrHeader(i) = .Fields(i).Name
25 Next
26 End With
27
28 getTableHeader = True
29
30ExitHandler:
31
32 Exit Function
33
34ErrorHandler:
35
36 MsgBox "エラーが発生したため、マクロを終了します。" & _
37 vbLf & _
38 "関数名：" & FUNC_NAME & _
39 vbLf & _
40 "エラー番号：" & Err.Number & vbNewLine & _
41 Err.Description, vbCritical, TOOL_NAME
42
43 GoTo ExitHandler
44
45End Function
getTableDataBySQL
引数のSQL文字列をもとに得られたレコードセットのデータを二次元配列として取得し、
値返却用の変数に格納して呼び出し元に返す。
1'******************************************************************************************
2'*関数名 ：getTableDataBySQL
3'*機能 ：SQL文字列より得られたレコードセットのデータを二次元配列として取得
4'*引数 ：対象SQL文字列
5'*引数 ：結果返却用
6'*戻り値 ：True > 正常終了、False > 異常終了
7'******************************************************************************************
8Public Function getTableDataBySQL(ByVal sql As String, ByRef arrData() As Variant) As Boolean
9
10 '定数
11 Const FUNC_NAME As String = "getTableDataBySQL"
12
13 '変数
14 Dim rs As DAO.Recordset
15 Dim i As Long
16 Dim j As Long
17
18 On Error GoTo ErrorHandler
19
20 getTableDataBySQL = False
21 Erase arrData
22
23 Set rs = db.OpenRecordset(sql)
24 With rs
25 If .EOF Then GoTo TruePoint
26 .MoveLast
27 ReDim arrData(0 To .RecordCount - 1, 0 To .Fields.Count - 1)
28 .MoveFirst
29
30 i = 0
31 Do Until .EOF
32 For j = 0 To .Fields.Count - 1
33 arrData(i, j) = .Fields(j).Value
34 Next j
35 i = i + 1
36 .MoveNext
37 Loop
38 End With
39
40TruePoint:
41
42 getTableDataBySQL = True
43
44ExitHandler:
45
46 If Not rs Is Nothing Then rs.Clone: Set rs = Nothing
47
48 Exit Function
49
50ErrorHandler:
51
52 MsgBox "エラーが発生したため、マクロを終了します。" & _
53 vbLf & _
54 "関数名：" & FUNC_NAME & _
55 vbLf & _
56 "エラー番号：" & Err.Number & vbNewLine & _
57 Err.Description, vbCritical, TOOL_NAME
58
59 GoTo ExitHandler
60
61End Function
postDataToSheet
引数のシートオブジェクトの
一行目に指定されたテーブルヘッダー文字列配列を、
二行目以降にテーブルデータの二次元配列データを転記する。
1
2'******************************************************************************************
3'*関数名 ：postDataToSheet
4'*機能 ：シートに配列データを転記する
5'*引数 ：対象シート
6'*引数 ：シート名
7'*引数 ：ヘッダー配列
8'*引数 ：データ配列
9'*戻り値 ：True > 正常終了、False > 異常終了
10'******************************************************************************************
11Public Function postDataToSheet( _
12 ByVal tgtSheet As Object, _
13 ByVal sheetName As String, _
14 ByVal pArrHeader As Variant, _
15 ByVal pArrData As Variant _
16) As Boolean
17
18 '定数
19 Const FUNC_NAME As String = "postDataToSheet"
20
21 '変数
22
23 On Error GoTo ErrorHandler
24
25 postDataToSheet = False
26
27 With tgtSheet
28 .Name = sheetName
29 .Range(.cells(1, 1), .cells(1, UBound(pArrHeader) - LBound(pArrHeader) + 1)).Value = pArrHeader
30 .Range(.cells(2, 1), .cells(UBound(pArrData, 1) - LBound(pArrData, 1) + 2, UBound(pArrData, 2) - LBound(pArrData, 2) + 1)).Value = pArrData
31 '罫線
32 .Range(.cells(1, 1), .cells(UBound(pArrData, 1) - LBound(pArrData, 1) + 2, UBound(pArrData, 2) - LBound(pArrData, 2) + 1)).Borders.LineStyle = xlContinuous
33 '列幅調整
34 .Range(.Columns(1), .Columns(UBound(pArrHeader) - LBound(pArrHeader) + 1)).AutoFit
35 End With
36
37 postDataToSheet = True
38
39ExitHandler:
40
41 Exit Function
42
43ErrorHandler:
44
45 MsgBox "エラーが発生したため、マクロを終了します。" & _
46 vbLf & _
47 "関数名：" & FUNC_NAME & _
48 vbLf & _
49 "エラー番号：" & Err.Number & vbNewLine & _
50 Err.Description, vbCritical, TOOL_NAME
51
52 GoTo ExitHandler
53
54End Function
55
getJsonFromAPI
指定URLのWebAPIからJson文字列を取得する。
本ツールではGoogle Apps Script(GAS)上のAPIを叩いて
商品テーブルデータのもととなるJsonを取得する。
1
2'******************************************************************************************
3'*関数名 ：getJsonFromAPI
4'*機能 ：指定URLのAPIからJson文字列を取得
5'*引数 ：URL
6'*戻り値 ：Json文字列（Parse前）
7'******************************************************************************************
8Public Function getJsonFromAPI(URL As String) As String
9
10 '定数
11 Const FUNC_NAME As String = "getJsonFromAPI"
12
13 '変数
14 Dim objXMLHttp As Object
15
16 On Error GoTo ErrorHandler
17
18 getJsonFromAPI = ""
19
20 Set objXMLHttp = CreateObject("MSXML2.ServerXMLHTTP.6.0")
21 objXMLHttp.Open "GET", URL, False
22 objXMLHttp.Send
23
24
25 getJsonFromAPI = objXMLHttp.responseText
26
27ExitHandler:
28
29 Exit Function
30
31ErrorHandler:
32
33 MsgBox "エラーが発生したため、マクロを終了します。" & _
34 vbLf & _
35 "関数名：" & FUNC_NAME & _
36 vbLf & _
37 "エラー番号：" & Err.Number & vbNewLine & _
38 Err.Description, vbCritical, TOOL_NAME
39
40 GoTo ExitHandler
41
42End Function
43
実行すると
例えばフォームで一番下の「実行_(1)+(2)+(3)+(4)」ボタンを実行すると、
次のようなExcelブックがデスクトップ上に生成される。
サンプルとソースコードについて
こちらをご参照ください。
終わりに
GASを用いると簡単にJSONを返すAPIが作れるみたいですね。
知らなかったです。
関連記事
- [Access VBA] フォームのコントロールに対してWithEventsでイベントリスナークラスを作成する際に気をつけなければならないこと
- [VBA] クラスを利用するメリットと方法について & 簡単なサンプル（１）
- [Access VBA] サブフォーム上のレコードを挿入、削除する簡単なサンプル
- [Excel VBA]ポリモーフィズムを用いて、IF文を使わずラジオボタンごとの処理分岐を行う
- [Access VBA] デザインビューのテーブル定義を表形式でエクスポートするAccessツールを作成した