ADO SELECT
その１　接続ダイアログ表示編
Option Explicit
Private madcnnOra As ADODB.Connection
Private madrstOra As ADODB.Recordset
Sub vba_ado()
Dim dsn As String
Dim uid As String
Dim pwd As String
Dim strConn As String
Dim strsql As String
Dim iintCol As Integer
Dim strItem As Long
Dim i As Long
On Error GoTo errClick:
Sheets("Sheet1").Select
dsn = Evaluate("Sheet1!A2").Value
uid = Evaluate("Sheet1!C2").Value
pwd = Evaluate("Sheet1!D2").Value
strConn = "Provider=MSDASQL;Data Source=" & dsn & ";User ID=;Password=;"
Set madcnnOra = New ADODB.Connection
madcnnOra.ConnectionString = strConn
madcnnOra.CursorLocation = adUseServer
madcnnOra.Open
'MsgBox "接続成功", vbOKOnly + vbInformation
Sheets("Sheet2").Select
For i = 1 To 2
strsql = "select count(*) from テーブル where a ='" & Cells(i, 1) & "'"
Set madrstOra = New ADODB.Recordset
madrstOra.CursorType = adOpenForwardOnly
madrstOra.LockType = adOpenStatic
madrstOra.Open strsql, madcnnOra
'MsgBox "レコードセット取得成功", vbOKOnly + vbInformation
For iintCol = 0 To madrstOra.Fields.Count - 1
strItem = madrstOra.Fields(iintCol).Value
If strItem = 0 Then
Cells(i, 2) = "*"
End If
Next
madrstOra.Close
Set madrstOra = Nothing
'MsgBox "レコードセット破棄成功", vbOKOnly + vbInformation
Next i
exitClick:
Set madcnnOra = Nothing
'MsgBox "切断成功", vbOKOnly + vbInformation
MsgBox "お・わ・り", vbOKOnly + vbInformation
On Error Resume Next
Exit Sub
errClick:
MsgBox "msg=" & strADOErr, vbOKOnly + vbExclamation
Resume exitClick:
End Sub
Private Function strADOErr() As String
Dim iintLoop As Integer

If madcnnOra.Errors.Count = 0 Then
strADOErr = Error$
Else
For iintLoop = 0 To madcnnOra.Errors.Count - 1
strADOErr = strADOErr & vbCrLf & _
madcnnOra.Errors(iintLoop).Description & " (" & _
madcnnOra.Errors(iintLoop).NativeError & ")" & vbCrLf & _
madcnnOra.Errors(iintLoop).Source & " (" & _
madcnnOra.Errors(iintLoop).SqlState & ")" & vbCrLf
Next
End If
End Function 		　
その２　接続ダイアログ表示編
Option Explicit
Private madcnnOra As ADODB.Connection
Private madrstOra As ADODB.Recordset
Sub go()
Dim dsn As String
Dim uid As String
Dim pwd As String
Dim strConn As String
Dim strsql As String
Dim iintCol As Integer
Dim strItem As Long
Dim i As Long
On Error GoTo errClick:
Sheets("Sheet1").Select
dsn = Evaluate("Sheet1!A2").Value
uid = Evaluate("Sheet1!C2").Value
pwd = Evaluate("Sheet1!D2").Value
strConn = "Provider=MSDASQL;Data Source=" & dsn & ";User ID=;Password=;"
Set madcnnOra = New ADODB.Connection
madcnnOra.ConnectionString = strConn
madcnnOra.CursorLocation = adUseServer
madcnnOra.Open
'MsgBox "接続成功", vbOKOnly + vbInformation
'Sheets("Sheet2").Select
strsql = "select aitecd from  テーブル "
Set madrstOra = New ADODB.Recordset
madrstOra.CursorType = adOpenForwardOnly
madrstOra.LockType = adOpenStatic
madrstOra.Open strsql, madcnnOra
iintCol = 0
MsgBox madrstOra.RecordCount
Do While Not madrstOra.EOF
iintCol = iintCol + 1
'strItem = madrstOra.Fields(iintCol).Value
madrstOra.MoveNext
Loop
MsgBox iintCol
madrstOra.Close
Set madrstOra = Nothing
'MsgBox "レコードセット破棄成功", vbOKOnly + vbInformation
exitClick:
Set madcnnOra = Nothing
'MsgBox "切断成功", vbOKOnly + vbInformation
MsgBox "お・わ・り", vbOKOnly + vbInformation
On Error Resume Next
Exit Sub
errClick:
MsgBox "msg=" & strADOErr, vbOKOnly + vbExclamation
Resume exitClick:
End Sub
Private Function strADOErr() As String
Dim iintLoop As Integer
If madcnnOra.Errors.Count = 0 Then
strADOErr = Error$
Else
For iintLoop = 0 To madcnnOra.Errors.Count - 1
strADOErr = strADOErr & vbCrLf & _
madcnnOra.Errors(iintLoop).Description & " (" & _
madcnnOra.Errors(iintLoop).NativeError & ")" & vbCrLf & _
madcnnOra.Errors(iintLoop).Source & " (" & _
madcnnOra.Errors(iintLoop).SqlState & ")" & vbCrLf
Next
End If
End Function 		　
その３　ｓｅｌｅｃｔ
Option Explicit
'参照設定 Microsoft ActiveX Data Objects 2.8 Library
Dim conUdb As New ADODB.Connection
Dim cmdUdb As New ADODB.Command
Dim rstUdb As New ADODB.Recordset
Const strconUdb As String = "Provider=IBMDADB2.1;" & _
                            "Data Source=xxxxxDB;" & _
                            "Password=xxxxx;" & _
                            "User ID=xxxxx"
Const strSql As String = "SELECT * FROM xx.xxxxxT"

Private Sub Form_Load()
Dim strlogf As String
Dim lngfnum As Long
    lngfnum = FreeFile
    strlogf = App.Path & "\Select.txt"
    Open strlogf For Append Shared As #lngfnum
    conUdb.Open strconUdb
    cmdUdb.ActiveConnection = conUdb
    cmdUdb.CommandText = strSql
    Set rstUdb = cmdUdb.Execute(, , adCmdText)
    If rstUdb.EOF = False Then
        rstUdb.MoveFirst
        Do Until rstUdb.EOF
            DoEvents
            Print #lngfnum, rstUdb!TBLID
            rstUdb.MoveNext
        Loop
    End If
    rstUdb.Close
    Set rstUdb = Nothing
    Print #lngfnum, ""
    Close #lngfnum
    End
End Sub


Sub sample()
Dim strlogf As String
Dim lngfnum As Long
Const strSQL As String = "select * from xxdlib.xxx000t where A = '03' and B = '2006' and C = '209' "

    lngfnum = FreeFile
    strlogf = App.Path & "\Select.txt"
    Open strlogf For Append Shared As #lngfnum
       
    conUdb.Open strconUdb
    cmdUdb.ActiveConnection = conUdb
    cmdUdb.CommandText = strSQL
    'Set rstUdb = cmdUdb.Execute(, , adCmdText)
    Set rstUdb = New ADODB.Recordset
    rstUdb.Open strSQL, conUdb, adOpenKeyset, adLockPessimistic    'adLockOptimistic
    If rstUdb.EOF = False Then
        rstUdb.MoveFirst
        Do Until rstUdb.EOF
            DoEvents
            Print #lngfnum, rstUdb!syobetu, rstUdb!nendo, rstUdb!hsenno, rstUdb!timest
            'rstUdb!timest = current timestamp
            rstUdb.Update
            rstUdb.MoveNext
        Loop
    End If
    rstUdb.Close
    Set rstUdb = Nothing
   
    Print #lngfnum, ""
    Close #lngfnum

    End

End Sub