Access VBA GetCurrent Record on ActiveSheet カレントのテーブル/クエリ からレコードセットを抜き出す

前回の紹介

前回は名前のみわかる程度でした。
Access VBA Get CurrentTableDef 現在開いているテーブルを取得
これをさらに発展させて
データシート形式で開いているテーブル/クエリの現在カーソルがある行を
レコードセット化して
CSVとしてエクスポート
さらにエクスポート中にイミディエイトに
テーブル/クエリ名、列、行、総レコード数、値、項目名
を表示する。

参照設定

VBA
Access
stdole
DAO(ACEDAO.DLL)
ADOMD
ADODB
※64bitの場合はDaoはエラーになります。

今開いているテーブルのカレントのレコードを抜き出す

これはマイクロソフトのVBAを発展させたものです。
まずデータシートビュー形式で開かれているテーブルかどうかを判定します。
そして現在データがあるテーブル上の位置を取得します。
取得したらそれをクローンして、レコードセットにします。

GetacCurrentTableRecordvalue11

Sub GetacCurrentTableRecordvalue11()
''''''''''''''''''''''''''
'                       '
' QIIQ from QITA Ver1.1 '
'                       '
''''''''''''''''''''''''
' Feture
'Get Current opend Table Current Record Value
'''' Variable StateMent. -[ACCESS VBA]---------------------------------------------------------------
    Dim Db As dao.Database: Set Db = CurrentDb
    Dim tdf As TableDef, tdTgt() As TableDef, cnt As Long, acObj As AccessObject, AcCont As Container, acScr As Screen, acDataSheet
    Dim rs2 As Recordset2, rs2c As Recordset2, irec As Long, irow As Long, iCol As Long, Flds As Fields, i As Long
    Dim str As String, TotalRec As Long
    Dim Dt As Date: Dt = Now
    Dim sr As ADODB.Stream: Set sr = New ADODB.Stream

' This procedure demonstrates how to get a pointer to the
' current active datasheet.
    Dim objDatasheet As Object
    Dim lngFirstRow As Long
    Dim lngFirstColumn As Long
    Dim lngFirstHight As Long
    Dim lngCurrentRec As Long
    Const conNoActiveDatasheet = 2484
    cnt = 0
    Set acScr = Application.Screen
    If Application.CurrentObjectType <> acTable Then Exit Sub ' Table Only
    Set acDataSheet = acScr.ActiveDatasheet
    If acScr.ActiveDatasheet.Current1View <> acCurViewDatasheet Then Exit Sub ' DataSheet View Only
    lngFirstRow = acDataSheet.SelTop
    lngFirstColumn = acDataSheet.SelLeft
    lngFirstHight = acDataSheet.SelHeight
    lngCurrentRec = acDataSheet.CurrentRecord
    Debug.Print "The first item in this selection is located at " & _
"Row " & lngFirstRow & ", Column " & _
    lngFirstColumn, vbInformation
    Debug.Print DCount("*", Application.CurrentObjectName)
    On Error GoTo GetSelection_Err

'''' Get ActivedataSheet Dynaset (RecordSet2). -[Access VBA]----------------------------
    Set acScr = Application.Screen
    Set acDataSheet = acScr.ActiveDatasheet
    If Err.Number = 0 Then
    Set rs2 = acDataSheet.Dynaset
    irow = acDataSheet.CurrentRecord
    iCol = acDataSheet.ActiveControl.ColumnOrder
    TotalRec = DCount("*", acScr.ActiveControl.Parent.FormName)
    Else
    Set rs2 = acDataSheet.Dynaset
    End If
    Set rs2c = rs2.Clone 'Clone RecordSet
'''' [[ End ]] Get ActivedataSheet Dynaset (RecordSet2). -[Access VBA]----------------------------
'''' Adodb Stream. -[Access VBA]----------------------------
    sr.Charset = "utf-8"
    sr.Mode = adModeReadWrite
    sr.LineSeparator = adCRLF
    sr.Type = adTypeText
    sr.Open
'''' Get Data. -[Access VBA]----------------------------
    str = ""
    Set Flds = rs2c.Fields
    For i = 0 To Flds.Count - 1
    str = str & """" & Flds(i).Name & """" & ","
    Next i
    str = str & vbCrLf
    For i = 0 To Flds.Count - 1
    Debug.Print Flds(i).Value
    str = str & """" & Flds(i).Value & """" & ","
    Next i
    sr.WriteText str & vbCrLf, adWriteChar
    Debug.Print str
    sr.WriteText "Tb/Q Name" & "," & " icol " & "," & "Rows" & "," & "Totalrecs" & "," & "Value" & "," & "acCtrLname"
    Debug.Print "Tb/Q Name" & "," & " icol " & "," & "Rows" & "," & "TotalRecs" & "," & "Value" & "," & "acCtrLname"
    Debug.Print acScr.ActiveControl.Parent.FormName & "," & iCol & "," & irow & "," & TotalRec & "," & acDataSheet.ActiveControl.Value & "," & acScr.ActiveControl.Name
    sr.WriteText acScr.ActiveControl.Parent.FormName & "," & iCol & "," & irow & "," & TotalRec & "," & acDataSheet.ActiveControl.Value & "," & acScr.ActiveControl.Name
    sr.SaveToFile CurrentProject.Path & "\" & "resultUtf8" & Format(Dt, "YYYYMMddHHmmss") & ".csv", adSaveCreateOverWrite
    GoTo Terminate
    Exit Sub
GetSelection_Bye:
    Exit Sub
Terminate:
    If Not sr Is Nothing Then Set sr = Nothing: Resume GetSelection_Bye
GetSelection_Err:
    If Err = conNoActiveDatasheet Then
    MsgBox "No data sheet is active.", vbExclamation
    Resume GetSelection_Bye
    End If
End Sub

今開いているクエリのカレントのレコードを抜き出す。

QueryではDynasetができない

Tabledefと違うのはDynasetができないことです。正確にいうとDynasetはローカルウィンドウでは表示されますが、VBAではエラーになります。VBA以外では抜けるのかもしれません。
　このためアクティブコントロールを使い、データを抜き出しました。

GetOpenCurrentQueryCurrentRecordData

Sub GetOpenCurrentQueryCurrentRecordData()
''''''''''''''''''''''''''''''''''''
' '                        ''
' QIIQ from QITA ''
' '                        ''
''''''''''''''''''''''''''''''''''''
' Featur
' Query Opened DataSheetView And Current ,get Current Record data to immediate Window
' Remark
' 1 record you get even if you select mutiple rows
    Dim cDB As dao.Database: Set cDB = CurrentDb
    Dim acScr As Screen
    Dim acViW
    Dim acDataSheet
    Dim acChild, acObj As AccessObject, acObjName As String
    Dim rs2 As Recordset2, rs As Recordset, strFilter As String, Qdef As QueryDef, Qtmp As QueryDef
    Dim iType As Long
    Dim iCol As Long, irow As Long
    Dim sSQL As String
    Dim i As Long
    Dim buf As String, str As String
'''' Check And Set Variable -[ ACCESS VBA ] ---------------------------------------------------------------------------------
    iType = Application.CurrentObjectType
    If iType <> acQuery Then GoTo Terminator ' Query Only
    acObjName = Application.CurrentObjectName
    Set acObj = Application.CurrentData.AllQueries(acObjName)
    Set acScr = Application.Screen
    Set acChild = acScr.ActiveControl
    If acObj.CurrentView <> acCurViewDatasheet Then GoTo Terminator 'Datasheetview only
    Set Qdef = cDB.QueryDefs(acObjName)
    iCol = acChild.ColumnOrder
    irow = acScr.ActiveDatasheet.CurrentRecord
    Debug.Print "クエリ名:" & Qdef.Name & "列:=" & iCol, "行:=" & irow, "acChild.seltext:", acChild.SelText
    For i = 0 To acScr.ActiveDatasheet.Controls.Count - 1
    str = str & acScr.ActiveDatasheet.Controls(i).Name & ","
    buf = buf & acScr.ActiveDatasheet.Controls(i) & ","
   Next i
   Debug.Print str & vbCrLf & buf
   buf = ""
    sSQL = Qdef.SQL: 'Debug.Print "sSQL" & vbCrLf & sSQL
    On Error GoTo Terminator
'    Set rs = cDB.OpenRecordset(sSQL)
'    rs.MoveFirst
'    For i = 1 To irow
'    rs.MoveNext
'    Next
'    For i = 0 To rs.Fields.Count - 1
'    buf = buf & rs.Fields(i).Name & ","
'    Next
'    buf = buf & vbCrLf
'    For i = 0 To rs.Fields.Count - 1
'    buf = buf & rs.Fields(i).Value & ","
'    Next
'    Debug.Print buf
    GoTo Finally
    Exit Sub
Finally:
  Exit Sub
Terminator:
    If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description
    Err.Clear: Resume Finally
End Sub

参考

レコードセットを使わずにレコード数を取得する方法 - T's Ware
Screen.ActiveDatasheet プロパティ (Access)

VBAのコード(旧 バグがありますので使わないでください)

当初はテーブルとクエリを一体で扱えるかと思ったのですが、エラーが出るようです。

GetacCurrentTableRecordvalue

Sub GetOpenCurrentQueryCurrentRecordData()
''''''''''''''''''''''''''''''''''''
' '                        ''
' QIIQ from QITA ''
' '                        ''
''''''''''''''''''''''''''''''''''''
' Featur
' Query Opened DataSheetView And Current ,get Current Record data to immediate Window
' Remark
' 1 record you get even if you select mutiple rows
    Dim cDB As dao.Database: Set cDB = CurrentDb
    Dim acScr As Screen
    Dim acViW
    Dim acDataSheet
    Dim acChild, acObj As AccessObject, acObjName As String
    Dim rs2 As Recordset2, rs As Recordset, strFilter As String, Qdef As QueryDef
    Dim iType As Long
    Dim iCol As Long, irow As Long
    Dim sSQL As String
    Dim i As Long
    Dim buf As String, str As String
'''' Check And Set Variable -[ ACCESS VBA ] ---------------------------------------------------------------------------------
    iType = Application.CurrentObjectType
    On Error GoTo Terminator
    If iType <> acQuery Then Debug.Print "" ' Query Only
    acObjName = Application.CurrentObjectName
    Set acObj = Application.CurrentData.AllQueries(acObjName)
    Set acScr = Application.Screen
    Set acChild = acScr.ActiveControl
    If acObj.CurrentView <> acCurViewDatasheet Then Debug.Print "Datasheetview Only": MsgBox "Datasheetview Only", vbCritical + vbOKOnly, "GetOpenCurrentQueryCurrentRecord Query not datasheet view": Exit Sub 'Datasheetview only
    Set Qdef = cDB.QueryDefs(acObjName)
    iCol = acChild.ColumnOrder
    irow = acScr.ActiveDatasheet.CurrentRecord
    Debug.Print "クエリ名:" & Qdef.Name & "列:=" & iCol, "行:=" & irow, "acChild.seltext:", acChild.SelText
    For i = 0 To acScr.ActiveDatasheet.Controls.Count - 1
    str = str & acScr.ActiveDatasheet.Controls(i).Name & ","
    buf = buf & acScr.ActiveDatasheet.Controls(i) & ","
   Next i
   Debug.Print str & vbCrLf & buf
   buf = ""
    sSQL = Qdef.SQL: 'Debug.Print "sSQL" & vbCrLf & sSQL

'    Set rs = cDB.OpenRecordset(sSQL)
'    rs.MoveFirst
'    For i = 1 To irow
'    rs.MoveNext
'    Next
'    For i = 0 To rs.Fields.Count - 1
'    buf = buf & rs.Fields(i).Name & ","
'    Next
'    buf = buf & vbCrLf
'    For i = 0 To rs.Fields.Count - 1
'    buf = buf & rs.Fields(i).Value & ","
'    Next
'    Debug.Print buf
    GoTo Finally
    Exit Sub
Finally:
  Exit Sub
Terminator:
    If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description: Err.Clear: Resume Finally    
End Sub