前回の紹介
前回は名前のみわかる程度でした。
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