ExcelでSQLを使う-018: ソース公開-02 DBSelect関数（Excel←→Access）
５頭の仔犬は、体調抜群で順調に新生児期前半を過ごしています。
◇◇◇◇◇
２、Accessを参照するDBSelect関数
DBSelect関数も、1996年に書いた次の関数が原型です。
【Access ライブラリ関数】
Public Function DBSelect(ByVal strQuerySQL As String, _
Optional colDelimita As String = ";", _
Optional rowDelimita As String = ";") As String
On Error GoTo Err_DBSelect
Dim R As Integer ' 行インデックス
Dim N As Integer ' 行総数 - 1
Dim cnn As Object
Dim rst As Object
Dim fld As ADODB.Field
Dim strList As String ' 全てのデータを区切子で連結して格納
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
With rst
.Open strQuerySQL, _
CurrentProject.Connection, _
adOpenStatic, _
adLockReadOnly
If Not .BOF Then
N = .RecordCount - 1
.MoveFirst
For R = 0 To N
For Each fld In .Fields
With fld
strList = strList & .Value & colDelimita
End With
Next fld
strList = Mid(strList, 1, Len(strList) - 1) & rowDelimita
.MoveNext
Next R
Else
strList = ""
End If
End With
DBSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", rowDelimita & "[END]", ""), "")
Exit_DBSelect:
On Error Resume Next
rst.Close
Set rst = Nothing
Exit Function
Err_DBSelect:
If isEcho Then
MsgBox "SELECT 文の実行時にエラーが発生しました。(DBSelect)" & Chr(13) & Chr(13) & _
"・Err.Description=" & Err.Description & Chr(13) & _
"・SQL Text=" & strQuerySQL, _
vbExclamation, " 関数エラーメッセージ"
End If
Resume Exit_DBSelect
End Function
Excel版DBSelect関数では For-Next文ではなくて Do-Loop Until() でデータを読み込んでいます。それは、ADOの.RecordCountの型がバージョンによって違うからです。型をキャストすれば For-Next文という手法を引き続き使えますが、今回は一般的なそれを採用しました。私的には、 For-Next文がスタック領域を使う（？）ので速いと思っています。
【Excel ライブラリ関数】
Public Function DBSelect(ByVal strSQL As String, _
ByVal strDB As String, _
Optional ByVal colDelimita As String = ";", _
Optional ByVal rowDelimita As String = ";", _
Optional ByVal withFieldInfo As Boolean = False, _
Optional ByVal withCounter As Boolean = False) As String
On Error GoTo Err_DBSelect
Dim cnn As Object
Dim rst As Object
Dim fld As Object
Dim intCounter As Integer
Dim strWhere As String
Dim strList As String
Dim strCountSQL As String
' ---------------
' Set
' ---------------
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' ----------------------------------
' データベース オープン
' ----------------------------------
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB & ";"
' ----------------------------------------
' レコードセット オープン
' ----------------------------------------
With rst
.Open strSQL, cnn
If Not .BOF Then
.MoveFirst
If withFieldInfo Then
'
' 列名を先頭に付与する
'
If withCounter = True Then
strList = "№" & colDelimita
End If
For Each fld In .Fields
strList = strList & fld.Name & colDelimita
Next fld
strList = strList & rowDelimita
strList = Replace(strList, colDelimita & rowDelimita, rowDelimita)
'
' 列タイプも先頭に付与する
'
If withCounter = True Then
strList = strList & "5" & colDelimita
End If
For Each fld In .Fields
strList = strList & fld.Type & colDelimita
Next fld
strList = strList & rowDelimita
strList = Replace(strList, colDelimita & rowDelimita, rowDelimita)
End If
'
' フィールドデータを読み込む
'
Do
intCounter = intCounter + 1
If withCounter = True Then
strList = strList & Format(intCounter,"0.00") & colDelimita
End If
For Each fld In .Fields
With fld
strList = strList & .Value & colDelimita
End With
Next fld
strList = Mid(strList, 1, Len(strList) - 1) & rowDelimita
.MoveNext
Loop Until (.EOF)
Else
strList = ""
End If
End With
Exit_DBSelect:
On Error Resume Next
rst.Close
Set rst = Nothing
DBSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", rowDelimita & "[END]", ""), "")
Exit Function
Err_DBSelect:
MsgBox Err.Description
Resume Exit_DBSelect
End Function
DBSelect関数の使用例_1
次の例では、行区切り子に改行コード（Asccii Code 13）を指定しています。
Sub Macro1()
Dim strSQL As String
Dim strDB As String
strSQL = "SELECT * FROM [蔵書リスト] ORDER BY ID"
strDB = "D:\DB1.mdb"
Debug.Print DBSelect(strSQL, strDB, , Chr(13))
End Sub
DBSelect関数の使用例_2
本稿を書いている途中で急遽、DBSelect関数の結果をシートに書き出すDBWriter関数とSheetWriter関数を思い立ちました。そして、書き上げました。DBSelect関数を利用すれば、Accessのテーブルを丸ごとエクセルのシートにコピペする関数も容易に作成できます。
Public Function DBMWriter(ByVal strSQL As String, _
ByVal strDB As String, _
ByVal strSheetName As String) As Boolean
・・・・・
strList = DBSelect(strSQL, strDB, , "|", True, True)
isOK = SheetWriter(strList, strSheetName)
・・・・・
End Function
Sub Macro2()
Dim strSQL As String
Dim strDB As String
strSQL = "SELECT * FROM [蔵書リスト] ORDER BY ID"
strDB = "D:\DB1.mdb"
Call DBWriter(strSQL, strDB, "New")
End Sub
DBWriter関数は、DBSelect関数の結果をSheetWriter関数に渡すというたった２行の関数。SheetWriter関数は、受け取ったデータをただ単に書き出すというシンプルなもの。この両者については、次の次に紹介します。
