Any way I can run a select query within the immediate console of VBA Access 2010 (VBA 7.0)?
This worked for me with a query that return integers:
Public Sub runQuery(ByVal query As String)
Dim DB As DAO.Database: Set DB = CurrentDb()
Dim rst As DAO.Recordset: Set rst = DB.OpenRecordset(query)
Do While Not rst.EOF
Dim rowStr As String: rowStr = ""
Dim fld As Field
For Each fld In rst.Fields
rowStr = rowStr & fld & " "
Next fld
Debug.Print (rowStr)
rst.MoveNext
Loop
End Sub
Then call it from the immediate window:
runQuery "SELECT Foo, Bar FROM MyTable WHERE Foo < 42"
Related
I created a query separately and now want to use VBA to read its records and then send certain fields of all rows in an email.
I am currently stuck on trying to extract all the rows from the recordset. I know how to do it for one record, but not with a dynamic recordset. Every week, the recordset could potentially have 1-10 (approx.) records. I had hoped to do this by dynamically reading all rows, saving the fields that I want into variables, and then adding that to the email body, but I arrived at an error.
I'm getting an error that says: Run-time error '3265': Item not found in this collection.
Does anyone know how to fix this error and how I can put all resulting rows of the recordset into the email body?
The code:
Private Sub Form_Timer()
'current_date variable instantiated in a module elsewhere
current_date = Date
'Using the Date function to run every Monday, regardless of the time of day
If current_date = (Date - (DatePart("w", Date, 2, 1) - 1)) Then
'MsgBox ("the current_date variable holds: " & current_date)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim varRecords As Variant
Dim intNumReturned As Integer
Dim intNumColumns As Integer
Dim intColumn As Integer
Dim intRow As Integer
Dim strSQL As String
Dim rst_jobnumber As String
Dim rst_bfloc As String
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_BMBFLoc")
Set rst = qdf.OpenRecordset
If rst.EOF Then
MsgBox "Null."
Else
'Found this part of the code online and not sure if I'm using it right.
varRecords = rst!GetRows(3)
intNumReturned = UBound(varRecords, 2) + 1
intNumColumns = UBound(varRecords, 1) + 1
For intRow = 0 To intNumReturned - 1
For intColumn = 0 To intNumColumns - 1
Debug.Print varRecords(intColumn, intRow)
Next intColumn
Next intRow
'End of code found online.
'rst.MoveFirst 'commenting this out because this query could potentially return multiple rows
rst_jobnumber = rst!job & "-" & rst!suffix
rst_bfloc = rst!Uf_BackflushLoc
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
'Dim oApp As Outlook.Application
'Dim oMail As MailItem
'Set oApp = CreateObject("Outlook.application")
'mail_body = "The following jobs do not have the special BF location set in Job Orders: " & rst_
'Set oMail = oApp.CreateItem(olMailItem)
'oMail.Body = mail_body
'oMail.Subject = "Blow Molding Jobs Missing BF Location"
'oMail.To = "something#something.com" 'in the future, create a function that finds all of the SC users' emails from their Windows user
'oMail.Send
'Set oMail = Nothing
'Set oApp = Nothing
End If
End If
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Try working with this code and see how it works for you. I was unsure if you were sending one email per or one email listing all (I assumed the latter)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strMessageBody As String
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset("qry_BMBFLoc")
strMessageBody = "The following jobs do not have the special BF location set in Job Orders: "
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
strMessageBody = strMessageBody & rst!job & "-" & rst!suffix & ","
rst.MoveNext
Loop
If Right(strMessageBody, 1) = "," Then strMessageBody = Left(strMessageBody, Len(strMessageBody)-1)
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
EDIT - not using dot operator
Replace
varRecords = rst!GetRows(3)
with
varRecords = rst.GetRows(3)
Do you have three rows in your recordset?
If not rst!GetRows(3) will return false - and then next line will fail when you try to use UBound.
A good example of how to implement GetRows
Another possibility is if you're trying to access a Field that's not in your recordset on a line that has rst!
My intention is to have user select one or several query names from the listbox and prompt the execution of queries with those names.
So far, I have this code:
Private Sub Command43_Click()
Dim rs As DAO.Recordset
Dim valSelect As Variant
Dim strValue As String
For Each valSelect In Me.Combo29.ItemsSelected
strValue = strValue & "'" & Me.Combo29.ItemData(valSelect) & "',"
strValue = Left(strValue, Len(strValue) - 1)
Set rs = CurrentDb.OpenRecordset(strValue)
Debug.Print rs
rs.Close
Set rs = Nothing
Next valSelect
MsgBox "Complete!"
End Sub
When running the code, I get error that Access can't find the query name.
Please help!
You can only open one query with one command, so try:
For Each valSelect In Me!Combo29.ItemsSelected
strValue = Me!Combo29.ItemData(valSelect)
Set rs = CurrentDb.OpenRecordset(strValue)
Debug.Print strValue, rs.RecordCount
Next
rs.Close
Set rs = Nothing
And do rename your controls to something meaningful.
I have a module with a procedure inside that looks like this:
Public Sub OpenRecordset()
Dim qdf As QueryDef
Set qdf = CurrentDb.QueryDefs("QOff2")
qdf.Parameters(0).Value = [Forms]![Form]![Text10]
Dim db As Database
Dim rs As Recordset
Dim StrBusinesses As String
Set rs = qdf.OpenRecordset
If rs.EOF And rs.BOF Then
MsgBox ("No businesses exist for this Customer")
Exit Sub
Else
rs.MoveFirst
End If
StrBusinesses = ""
Do While Not rs.EOF
StrBusinesses = StrBusinesses & rs!Fnam & ", "
rs.MoveNext
Loop
rs.Close
StrBusinesses = Left(StrBusinesses, Len(StrBusinesses) - 2)
Forms!Form.Badge = StrBusinesses
Set rs = Nothing
End Sub
I am trying to get this module to input the query results into a textbox (forms!form.badge), but I can't seem to get it to do it like my 5 other dlookup functions. When I open up the module and push the green play button, it shows up on the correct textbox but also shows up on the other records as well. It also doesn't show up automatically, nor does it update as you enter in the parameters. Isn't a module supposed to help autofil numerous variables into a text box in place of dlookup for multiple values?
No. If Forms!Form!Badge is an unbound textbox, a value assigned to it will be shown identically for all records.
To individualize, you will need a lookup function which takes the ID or other unique value of the record as parameter(add to textbox):
=LookupBadges([Forms]![Form]![Text10])
Public Function LookupBadges(ByVal Value As Variant) As Variant
Dim db As Database
Dim qd As QueryDef
Dim rs As Recordset
Dim Businesses As String
Set db = CurrentDb
Set qd = db.QueryDefs("QOff2")
qd.Parameters(0).Value = Nz(Value)
Set rs = qd.OpenRecordset
If rs.RecordCount > 0 Then
rs.MoveFirst
Do While Not rs.EOF
Businesses = Businesses & rs!Fnam.Value & ", "
rs.MoveNext
Loop
End If
rs.Close
Businesses = Left(Businesses, Len(Businesses) - 2)
LookupBadges = Businesses
Set rs = Nothing
Set qd = Nothing
Set db = Nothing
End Function
I'm trying to open a record set using a SQL string. I get run time error 3061 "Too Few Parameters." any help would be appreciated.
Dim stAppName As String
Dim stURL As String
Dim rst As Recordset
Dim dbs As Database
Dim stringToSearch As Integer
Dim strSQL As String
Set dbs = CurrentDb
stringToSearch = InputBox("What is your route #?", "Enter route #: ")
strSQL = "SELECT ESRP.* FROM ESRP WHERE ESRP.Route=stringToSearch"
Set rst = dbs.OpenRecordset(strSQL)
Please change the code line of strSQL as follows, as suggested by Fionnuala you need to use variable outside the quotes.
Assuming Route field is Text data type, we need to put single quote for strings, if its number no single quote, for dates put # instead of single quote
strSQL = "SELECT ESRP.* FROM ESRP WHERE ESRP.Route='" & stringToSearch & "'"
It's a little sample, maybe it can help you
Public Function fn_SQL_dbOpenRecordset(Optional vsql As String = "") As Recordset
Dim dbs As DAO.Database
Dim rs As Recordset
On Error GoTo END_CODE
'Set the database
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset(vsql, dbOpenForwardOnly) 'you can use: dbOpenDynamic; dbOpenSnapshot; dbOpenTable
Set fn_SQL_dbOpenRecordset = rs
Exit Function
END_CODE:
Set fn_SQL_dbOpenRecordset = Nothing
End Function
Public Sub Program_Test()
On Error GoTo ERROR_SUB
Dim rs As Recordset
Dim sName As String
sName = "Joe"
sName = "'" & sName & "'" 'WARNING: BE CAREFUL WITH SQL INJECTION !!! Google it
Set rs = fn_SQL_dbOpenRecordset("select * from table1 d where PersonName = " & sName)
Dim i As Long
i = 0
While Not rs.EOF
Debug.Print rs(0).Value & " - " & rs(1).Value
rs.MoveNext
Wend
ERROR_SUB:
On Error Resume Next
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
End Sub
I'm creating a table in VBA within a loop and when I run the code a table is created.
But the next time I run it, an error comes up telling me that the table exists and the remainder of the code is not executed.
How can I have it overwrite the existing table (from the previous run)?
Here is my code:
Option Compare Database
Public Function createTables()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim strSQL As String
strSQL = "Select SKUS from SKUS"
Set db = CurrentDb()
Set rst = db.OpenRecordset(strSQL)
Set fld = rst.Fields("SKUS")
'MsgBox fld.Value
rst.MoveFirst
Do While Not rst.EOF
Set tdf = db.CreateTableDef(fld.Value)
Set fld = tdf.CreateField("SKUS", dbText, 30)
tdf.Fields.Append fld
Set fld = tdf.CreateField("Count", dbInteger)
tdf.Fields.Append fld
db.TableDefs.Append tdf
rst.MoveNext
Loop
End Function
Can anyone help me out please?
Thanks!
I would simply delete the table before attempting to recreate it:
db.TableDefs.Delete fld.Value
You can check if the table exists with the following function.
Public Function TableExists(TabName As String) As Boolean
Dim db As DAO.Database
Dim Sdummy As String
Set db = CurrentDb()
On Error Resume Next
Sdummy = db.TableDefs(TabName).Name
TableExists = (Err.Number = 0)
End Function
If the function returns true, then issue following sql statement:
DROP TABLE SKUS
The usual method is to test then delete temp table, requiring more code and recordkeeping for calling procedures that run multiple maketables.
Here is a procedure that is all inclusive, gleaning the source table name from maketable, then deleting before recreating. Also returns number of new records.
Public Function fcnMakeTableForce(strMTQuery As String) As Integer
On Error GoTo ErrorExit
'Runs maketable, deleting the resulting temp table contained in the query (if it
'exists) beforehand. Also returns the number of records in new temp table
Dim dbs As Database
Dim strSQL As String
Set dbs = CurrentDb
'Get SQL from MakeTable
strSQL = dbs.QueryDefs(strMTQuery).sql
'Get target table from SQL:
intINTOPos = InStr(strSQL, "INTO [") + 5
intFROMPos = InStr(strSQL, "FROM [") - 3
strTargetTable = Mid(strSQL, intINTOPos + 1, intFROMPos - intINTOPos - 1)
'Clear target table if it exists
If (DCount("*", "MSysObjects", "[Name] = """ & strTargetTable & """")) > 0 Then
CurrentDb.TableDefs.Delete (strTargetTable)
End If
dbs.Execute strMTQuery
intRecordsAdded = DCount("*", strTargetTable)
fcnMakeTableForce = intRecordsAdded
NormalExit:
Exit Function
ErrorExit:
MsgBox "Error: " & Err.Description & vbCr & vbCr & "in Function: fcnMakeTableForce"
Resume NormalExit
End Function