ExcelでSQLを使う-021: ソース公開-05 CircledText関数（共用）

新生児期の仔犬の排泄を促すのはママ犬の大切な役目です。

◇◇◇◇◇

５、囲み文字を自動付与するCircledText関数

　SQL文に値をセットする場合には、データの種類によって決められた文字（囲み文字）で囲む必要があります。

Char ______"
Date ______#
String _____"

Integer ____なし

　悩ましいことには、データの種類による囲み文字を省くとSQL文の実行時にエラーが発生します。

Sub Test05()
　　Dim strDB　　 As String
　　Dim strValues As String
　　Dim strSQL　　As String
　　
　　strDB = "D:\db1.mdb"
　　strValues = "6,西島　英雄, にしじま　ひでお, 111134, 東京都, 墨田区, XX町)"
　　strSQL = "INSERT INTO 顧客台帳 VALUES(" & strValues & ") "
　　
　　Call CnnExecute(strSQL, strDB)
End Sub

　この問題を回避しないことには、エクセルで追加した顧客情報をAcessの[顧客台帳]に簡単にインサートすることはできません。

INSERT INTO 顧客台帳 (列リスト) VALUES (値リスト)

　仮に、 (列リスト) VALUES (値リスト)を自動生成してくれる関数があれば助かります。

[イミディエイトウインドウ]

? DSelect("SELECT * FROM [Sheet4$B1:H11] WHERE ID=6",,,,,,False)
6;西島　英雄;にしじま　ひでお;111134;東京都;墨田区;XX町
? CircledText("SELECT * FROM [Sheet4$B1:H11] WHERE ID=6", 1)
(ID,名前,読み,郵便番号,住所1,住所2,住所3) VALUES (6,'西島　英雄','にしじま　ひでお','111134','東京都','墨田区','XX町')

　次は、CircledText関数を用いてAccessの顧客台帳を更新するマクロです。

Sub Test06()
　　Dim I　　　　 As Integer
　　Dim strDB　　 As String
　　Dim strSelect As String
　　Dim strInsert As String
　　Dim strSQL　　As String
　　
　　strDB = "D:\db1.mdb"
　　strSelect = "SELECT * FROM [Sheet4$B1:H11] WHERE ID=XXXXX"
　　strInsert = "INSERT INTO 顧客台帳 "
　　For I = 6 To 10
　　　　strSQL = Replace(strSelect, "XXXXX", I)
　　　　Call CnnExecute(strInsert & CircledText(strSQL, 1), strDB)
　　Next I
End Sub

注意1: トップの行以外を検索する時は、2番目の引数を指定

　　CircledText(strSQL, 2)____該当する行の最初から2番目

　　CircledText(strSQL, -2) ___該当する行の最後から2番目

注意2: AccessへInsertする場合は、3番目の引数<>0

X　CircledText(strSQL)

O　CircledText(strSQL,, -1)

　CnnExecute関数でINSERT文を実行する強力な助っ人であるCircledText関数は、次のようです。

Public Function CircledText(ByVal strSQL As String, _
　　　　　　　　　　　　　　Optional ByVal intSearch As Integer = 0, _
　　　　　　　　　　　　　　Optional ByVal intForAccess As Integer = 0, _
　　　　　　　　　　　　　　Optional ByVal xlFileName As String = "", _
　　　　　　　　　　　　　　Optional ByVal isHeader As Boolean = True) As String
On Error GoTo Err_CircledText
　　'
　　' 【要参照設定】
　　'
　　' Micrsoft ActiveX Data Objects 2.8 Library
　　'
　　Dim R　　　　　As Integer
　　Dim N　　　　　As Integer
　　Dim M　　　　　As Integer
　　Dim strHDR　　 As String
　　Dim cnn　　　　As ADODB.Connection
　　Dim rst　　　　As ADODB.Recordset
　　Dim fld　　　　As ADODB.Field
　　Dim strColList As String
　　Dim strValues　As String
　　
　　Set cnn = New ADODB.Connection
　　Set rst = New ADODB.Recordset
　　'
　　' ThisWorkbook.FullName の指定
　　'
　　If Len(xlFileName) = 0 Then
　　　　 xlFileName = ThisWorkbook.FullName
　　End If
　　'
　　' 接続設定
　　'
　　With cnn
　　　　strHDR = IIf(isHeader, "HDR=YES", "HDR=NO")
　　　　.Provider = "Microsoft.ACE.OLEDB.12.0"
　　　　.Properties("Extended Properties") = "Excel 12.0;" & strHDR & ";IMEX=1"
　　　　.Open xlFileName
　　　　'
　　　　' 列を読み込み
　　　　'
　　　　With rst
　　　　　　.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
　　　　　　N = CInt(.RecordCount)
　　　　　　If intSearch < 0 Then
　　　　　　　　intSearch = N + intSearch + 1
　　　　　　End If
　　　　　　If Not .BOF Then
　　　　　　　　strColList = "("
　　　　　　　　strValues = "("
　　　　　　　　intSearch = intSearch - 1
　　　　　　　　'
　　　　　　　　'　MoveFirst
　　　　　　　　'
　　　　　　　　M = N - 1
　　　　　　　　For R = 0 To M
　　　　　　　　　　If intSearch = R Then
　　　　　　　　　　　　'
　　　　　　　　　　　　' データを呼び込む
　　　　　　　　　　　　'
　　　　　　　　　　　　For Each fld In .Fields
　　　　　　　　　　　　　　strColList = strColList & fld.Name & ","
　　　　　　　　　　　　　　If intForAccess = 0 Then
　　　　　　　　　　　　　　　　If Len(fld.Value & "") > 0 Then
　　　　　　　　　　　　　　　　　　Select Case fld.Type
　　　　　　　　　　　　　　　　　　　　Case 202　' 文字列型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & "'" & fld.Value & "',"
　　　　　　　　　　　　　　　　　　　　Case 3, 5　　' 数字型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & fld.Value & ","
　　　　　　　　　　　　　　　　　　　　Case 6　　' 通貨型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & fld.Value & ","
　　　　　　　　　　　　　　　　　　　　Case 7　　' 日付時刻型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & "'" & fld.Value & "',"
　　　　　　　　　　　　　　　　　　　　Case Else
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & fld.Value & ","
　　　　　　　　　　　　　　　　　　End Select
　　　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　　　strValues = strValues & "null,"
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　If Len(fld.Value & "") > 0 Then
　　　　　　　　　　　　　　　　　　Select Case fld.Type
　　　　　　　　　　　　　　　　　　　　Case 202　' 文字列型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & "'" & fld.Value & "',"
　　　　　　　　　　　　　　　　　　　　Case 3, 5　 ' 数字型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & fld.Value & ","
　　　　　　　　　　　　　　　　　　　　Case 6　　' 通貨型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & fld.Value & ","
　　　　　　　　　　　　　　　　　　　　Case 7　　' 日付時刻型
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & "#" & fld.Value & "#,"
　　　　　　　　　　　　　　　　　　　　Case Else
　　　　　　　　　　　　　　　　　　　　　　strValues = strValues & fld.Value & ","
　　　　　　　　　　　　　　　　　　End Select
　　　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　　　strValues = strValues & "null,"
　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　Next fld
　　　　　　　　　　End If
　　　　　　　　　　.MoveNext
　　　　　　　　Next R
　　　　　　End If
　　　　End With
　　　　strColList = Left(strColList, Len(strColList) - 1)
　　　　strValues = Left(strValues, Len(strValues) - 1)
　　End With
CircledText = IIf(Len(strColList & "") > 0, strColList & ") VALUES " & strValues & ")", "")
Exit_CircledText:
On Error Resume Next
　　rst.Close
　　Set rst = Nothing
　　Exit Function
Err_CircledText:
　　MsgBox "SELECT 文の実行時にエラーが発生しました。(CircledText)" & Chr(13) & Chr(13) & _
　　　　　　"・Err.Description=" & Err.Description & Chr(13) & _
　　　　　　"・SQL Text=" & strSQL, _
　　　　　　vbExclamation, " 関数エラーメッセージ"
　　Resume Exit_CircledText
End Function