Attribute VB_Name = "ador1"
'___________________________________________________________
'sample-vbaxlado1-1 version 1.1, Copyright (C) 2001 Tomizono <tomizono@yahoo.com>
'sample-vbaxlado1-1 comes with ABSOLUTELY NO WARRANTY. This is free software,
'and you are welcome to redistribute it under certain conditions.
'See http://www.gnu.org/copyleft/gpl.html#SEC3 for details.
'___________________________________________________________
'discribes howto treat ADO Recordset objects.
'this is a VBA module source for MS Excel.
'this version: http://www.geocities.com/tomizono/gpl/2001/sample-vbaxlado1-1.1.1.bas
'lattest: http://www.geocities.com/tomizono/gpl/sample-vbaxlado1-1.bas
'
'Further information is available at:
'http://www.geocities.com/tomizono/vba/db.ado1.html
'___________________________________________________________
'sample-vbaxlado1-1: discribes howto treat ADO Recordset objects.
'Copyright (C) 2001 Tomizono <tomizono@yahoo.com>
'
'This program is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published by
'the Free Software Foundation; either version 2 of the License, or
'(at your option) any later version.
'
'This program is distributed in the hope that it will be useful,
'but WITHOUT ANY WARRANTY; without even the implied warranty of
'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'GNU General Public License for more details.
'
'You should have received a copy of the GNU General Public License
'along with this program; if not, write to the Free Software
'Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
'___________________________________________________________

Option Explicit

'---- CursorTypeEnum Values ----
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

'---- DataTypeEnum Values ----
Const adChapter = 136

Function ado1(Con As String, SQL As String)
' ADO接続文字列と SQL文字列をもらって、最初のレコードの内容を返す関数。
    Dim Rs1 As Object, FieA As Object
    Dim a As String
    a = ""
    Set Rs1 = CreateObject("ADODB.Recordset")
    Rs1.Open SQL, Con, adOpenForwardOnly
    If Not Rs1.EOF Then
        For Each FieA In Rs1.Fields
            a = a & "<" & FieA.Name & ">" & FieA.Value
        Next FieA
    End If
    Rs1.Close
    Set Rs1 = Nothing
    ado1 = a
End Function

Sub ado2()
' さまざまな接続定数を試してみる。
' Access MDB
    Dim Source As String, Con As String
    Source = "select * from Table1 where c=6"
    ' Microsoft OLE DB Provider for Microsoft Jet
    Con = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\opt\access1.mdb;User ID=Admin;Password=;"
    MsgBox ado1(Con, Source)
    ' Microsoft OLE DB Provider for ODBC
    ' DSN を使う記述
    Con = "Provider=MSDASQL;DSN=db1;UID=Admin;PWD=;"
    MsgBox ado1(Con, Source)
    ' ODBC はデフォルトプロバイダーなので省略記述できる。
    Con = "DSN=db1;"
    MsgBox ado1(Con, Source)
    ' FileDSN を使う記述
    Con = "FileDSN=fdb1;"
    MsgBox ado1(Con, Source)
    ' Driver を使う記述
    Con = "Driver={Microsoft Access Driver (*.mdb)};UID=Admin;PWD=;DBQ=C:\opt\access1.mdb;"
    MsgBox ado1(Con, Source)
    ' フォーマルな記述(1)
    Con = "Provider=MSDASQL;Extended Properties=""Driver={Microsoft Access Driver (*.mdb)};DBQ=C:\opt\access1.mdb;DefaultDir=C:\opt;Exclusive=0;FIL=MS Access;MaxBufferSize=512;PageTimeout=5;ReadOnly=1;UID=Admin;PWD=;"""
    MsgBox ado1(Con, Source)
    ' フォーマルな記述(2)
    Con = "Provider=MSDASQL;Persist Security Info=False;Extended Properties=""DSN=MS Access 97 Database;DBQ=C:\opt\access1.mdb;DefaultDir=C:\opt;DriverId=25;Exclusive=0;FIL=MS Access;MaxBufferSize=512;PageTimeout=5;ReadOnly=1;UID=Admin;"""
    MsgBox ado1(Con, Source)
End Sub

Sub ado3()
' さまざまな接続定数を試してみる。
' ファイル用の ODBC ドライバ
    Dim Source As String, Con As String
    Source = "select * from Table1 where c=6"
    ' ODBC Excel Driver
    ' C:\opt\Book1.xls にある "Table1"という名前の Range を扱う。
    ' Souce = "A1:C3" というように Range の直接指定も可能。
    Con = "Driver={Microsoft Excel Driver (*.xls)};DBQ=C:\opt\Book1.xls;"
    MsgBox ado1(Con, Source)
    ' ODBC Text Driver
    ' C:\opt\Table1 というテキストファイルを扱う。
    Con = "Driver={Microsoft Text Driver (*.txt; *.csv)};DBQ=C:\opt;"
    MsgBox ado1(Con, Source)
End Sub

Sub ado4()
' さまざまな接続定数を試してみる。
' オラクル
    Dim Source As String, Con As String
    Source = "select * from Table1 where c=6"
    ' Microsoft OLE DB Provider for Oracle
    Con = "Provider=MSDAORA;Data Source=serverName;User ID=userName; Password=userPassword;"
    MsgBox ado1(Con, Source)
    ' ODBC
    Con = "Driver={Oracle ODBC Driver};UID=userName;PWD=userPassword;DBQ=serviceName"
    MsgBox ado1(Con, Source)
End Sub

Sub ado5()
' レコードを読み、セルに格納する。
    Dim Source As String, Con As String
    Dim Rs1 As Object, FieA As Object
    Dim x As Range, y As Range
    Set x = ActiveCell
    Set y = x.EntireColumn
    Con = "DSN=db1;"
    Source = "Select * From Table1 WHERE ID Between 1 And 10"
    Set Rs1 = CreateObject("ADODB.Recordset")
    Rs1.Open Source, Con, adOpenForwardOnly
    For Each FieA In Rs1.Fields
        x.Value = FieA.Name
        Set x = x.Next
    Next FieA
    Set x = Intersect(x.Rows(2).EntireRow, y)
    Do Until Rs1.EOF
        For Each FieA In Rs1.Fields
            x.Value = FieA.Value
            Set x = x.Next
        Next FieA
        Set x = Intersect(x.Rows(2).EntireRow, y)
    Rs1.MoveNext
    Loop
    Rs1.Close
    Set Rs1 = Nothing
End Sub

Sub ado6()
' レコードを更新する。
    Dim Source As String, Con As String
    Dim Rs1 As Object
    Con = "DSN=db1;"
    Source = "Select * From Table1 WHERE ID = 3"
    Set Rs1 = CreateObject("ADODB.Recordset")
    Rs1.Open Source, Con, adOpenDynamic, adLockOptimistic
    Rs1.Fields("Hiduke").Value = Now()
    Rs1.Update
    Rs1.Close
    Set Rs1 = Nothing
End Sub

Sub ado7()
' レコードを追加する。
    Dim Source As String, Con As String
    Dim Rs1 As Object
    Con = "DSN=db1;"
    Source = "Select * From Table1 WHERE ID = 3"
    Set Rs1 = CreateObject("ADODB.Recordset")
    Rs1.Open Source, Con, adOpenDynamic, adLockOptimistic
    Rs1.addnew
    Rs1.Fields("Hiduke").Value = Now()
    Rs1.Update
    Rs1.Close
    Set Rs1 = Nothing
End Sub

Sub ado8()
' レコードを削除する。
    Dim Source As String, Con As String
    Dim Rs1 As Object
    Con = "DSN=db1;"
    Source = "Select * From Table1 WHERE ID = 3"
    Set Rs1 = CreateObject("ADODB.Recordset")
    Rs1.Open Source, Con, adOpenDynamic, adLockOptimistic
    Rs1.Delete
    Rs1.Update
    Rs1.Close
    Set Rs1 = Nothing
End Sub

Sub ado10()
' さまざまな接続定数を試してみる。
' XML用の OLE DB ドライバ (ADO 2.6 以上)
    Dim Source As String, Con As String
    Dim x As Range, Rs1 As Object
    Set x = ActiveCell
    ' Microsoft OLE DB Simple Provider
    ' XML ファイルを、入れ子の Recordset として返す。
    ' データソースは、ファイル名または URL を指定する。
    Source = "C:\opt\table1.xml"
    Source = "http://someurl/opt/table1.xml"
    Con = "Provider=MSDAOSP; Data Source=MSXML2.DSOControl;"
    Set Rs1 = CreateObject("ADODB.Recordset")
    Rs1.Open Source, Con, adOpenForwardOnly
    ado11 Rs1, x
    Rs1.Close
    Set Rs1 = Nothing
End Sub

Function ado11(Rs1 As Object, x As Range) As Range
' ADO-XML レコードセットをセルに書き出す。
    Dim FieA As Object, Rs2 As Object
    Dim i As Long
    i = 1
    Do While Not Rs1.EOF
        For Each FieA In Rs1.Fields
            If FieA.Type = adChapter Then
                Set Rs2 = FieA.Value
                Set x = ado11(Rs2, x(i + 1, 2))(2, 0)
                i = 1
                Set Rs2 = Nothing
            Else
                x(i) = FieA.Name
                x(i, 2) = FieA.Value
                'x(i, 3) = FieA.Type
                i = i + 1
            End If
        Next
    Rs1.MoveNext
    Loop
    Set ado11 = x(i)
End Function