using a variable to Set rst - ms-access

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

Related

Split unpredictable length comma separated field not taking first record in series

I am running some code to split a slash-separated field into multiple rows, but the first value in the series is not carrying over. Does anyone know what I'm missing. Also, Rows that only have one record are not carrying over.
Public Sub ReformatTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsADD As DAO.Recordset
Dim strSQL As String
Dim strMPG, strBusinessName, strCustomerNumber, strCustomerName, strCountStartDate, strCCStatus As String
Dim strSplitMPG As String
Dim varData As Variant
Dim i As Integer
Set db = CurrentDb
' Select all eligible fields (have a comma) and unprocessed (SPLIT_MPG is Null)
strSQL = "SELECT BUSINESS_NAME, CUSTOMER_NUMBER, CUSTOMER_NAME, COUNT_START_DATE, CC_STATUS, MPG, SPLIT_MPG FROM [tmStarCycleCountStatuses_SlashesforCommas] WHERE ([MPG] Like ""*/*"") AND ([SPLIT_MPG] Is Null)"
Set rsADD = db.OpenRecordset("tmStarCycleCountStatuses_SlashesforCommas", dbOpenDynaset, dbAppendOnly)
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !MPG
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
strCustomerName = !CUSTOMER_NAME
strCountStartDate = !COUNT_START_DATE
strCCStatus = !CC_STATUS
varData = Split(strMPG, "/") ' Get all comma delimited fields
' Update First Record
.Edit
!SPLIT_MPG = Trim(varData(0)) ' remove spaces before writing new fields
.Update
' Add records with same first field
' and new fields for remaining data at end of string
For i = 1 To UBound(varData)
With rsADD
.AddNew
!MPG = strMPG
!SPLIT_MPG = Trim(varData(i)) ' remove spaces before writing new fields
!BUSINESS_NAME = strBusinessName
!CUSTOMER_NUMBER = strCustomerNumber
!CUSTOMER_NAME = strCustomerName
!COUNT_START_DATE = strCountStartDate
!CC_STATUS = strCCStatus
.Update
End With
Next
.MoveNext
Wend
.Close
rsADD.Close
End With
Set rsADD = Nothing
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
I can't post images yet due to reputation constrictions, but here are some links.
Here's the multiple after the code:
https://s9.postimg.org/fn3u70b5b/Multiple.jpg
Here's the single records after code run:
https://s10.postimg.org/bfq9z4snt/Singles.jpg
I feel like there's something super simple that I'm missing here, but it looks like I'm already taking the MPG over, so i'm curious as to why I'm not getting the singles or the first of the series. Any help would be appreciated! Thank you.
It looks right to me, except that you have to declare like this:
Dim strMPG As String
Dim strBusinessNames As String
Dim strCustomerNumbers As String
Dim strCustomerNames As String
Dim strCountStartDates As String
Dim strCCStatus As String
I guess you will have to insert some lines with Debug.Print .. to narrow down the happenings.
Got it. Ended up changing my approach. This code will work. The pattern, regardless of length, would always be the same, so I used a Right/Left combo and integers
Public Sub ReformatmStarCycleCountStatusesTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strMPG As String
Dim strBusinessName As String
Dim strCustomerNumber As String
Dim strCustomerName As String
Dim dteCountStartDate As Date
Dim strCCStatus As String
Dim strSplitMPG As String
Dim intRemainingLength As Integer
Dim intInitialLength As Integer
Dim intStartPoint As Integer
Dim varData As Variant
Set db = CurrentDb
DoCmd.SetWarnings False
' Select all eligible fields (have a comma)
strSQL = "SELECT * FROM [mStar Cycle Count Statuses] WHERE [PRODUCT_FILTER_VALUE] is not null"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !PRODUCT_FILTER_VALUE
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
dteCountStartDate = !COUNT_START_DATE
strCCStatus = !Status
intInitialLength = Len(strMPG)
intRemainingLength = intInitialLength
intStartPoint = 2
Do While intRemainingLength > 0
strSQL = "INSERT INTO tmStarCycleCountStatuses VALUES ('" & strBusinessName & "', '" & strCustomerNumber _
& "', #" & dteCountStartDate & "#, '" & strCCStatus & "', '" & Right(Left(strMPG, intStartPoint), 2) & "')"
DoCmd.RunSQL (strSQL)
intStartPoint = intStartPoint + 3
intRemainingLength = intRemainingLength - 3
Loop
intStartPoint = 1
.MoveNext
Wend
.Close
End With
DoCmd.SetWarnings True
Set rs = Nothing
db.Close
Set db = Nothing
End Sub

ACCESS VBA selecting multiple values from listbox and executing the query name

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.

Using iMacros with VBA to fill out a form on a site with a name then grab results for table of names

first off I am brand new to iMacros and not great with VBA (I know not a great start)
So my end game is to use iMacros to go to a site fill in a form on the site with a name from a table in access enter the name and grab some resulting text from that site grab the text and put it in a table. I will have to do this for each record in the table. So far this is what I have:
Dim Rs As DAO.Recordset 'recordset for list of names from VcWAuditUsers
Dim db As DAO.Database
Dim SQL As String
Dim Sql2 As String
Dim STRErr As String
Dim sTableName As String
Dim serverName As String
Dim dbName As String
Dim strUserCnt As Integer
Dim UserName As Variant
Dim StrSql As String
Dim iim1, iret
Set iim1 = CreateObject("imacros")
iret = iim1.iimInit
iret = iim1.iimPlayCode("URL GOTO=https://www.sam.gov/portal/public/SAM/)
sTableName = "vCPpAuditUsers"
serverName = GetLinkedServer(sTableName)
dbName = GetLinkedDatabase(sTableName)
SQL = "Select Distinct FName, LName from " & sTableName
Set db = CurrentDb
Set Rs = db.OpenRecordset(SQL)
If (Not Rs.EOF And Not Rs.BOF) Then
Rs.MoveLast
Rs.MoveFirst
With Rs
Do While (Rs.EOF = False)
UserName = Trim(![FName]) & " " & Trim(![LName])
MsgBox ("New Name: " & UserName)
strUserCnt = Rs.recordCount
MsgBox ("Number of rows: " & strUserCnt)
'set iMacros variables
iret = iim1.iimSet("CONTENT", UserName)
iret = iim1.iimPlay("Y:\Data\FS01-M\Healthcare\SAM_iMacro\SAMiMacro.iim")
If iret < 0 Then
MsgBox iim1.iimGetLastError()
End If
StrSql = "Insert Into ExceptionResults Values('" & UserName & "','" & iim1.iimGetExtract(1) & Now & "')"
MsgBox ("Test SqlInsert: " & StrSql)
.MoveNext
Loop
End With
Rs.Close
db.Close
End If
I know that I am missing some key stuff but I have been unable to find a good example to base what I am doing on.
Any help is greatly appreciated!
Thanks.
What I came up with:
Option Compare Database
Option Explicit
Private Sub cmdGetExceptions_Click()
Dim YNMess As String
YNMess = MsgBox("Do you wish to truncate results table ExceptionResults?", vbYesNo, "TRUNCATE?")
If YNMess = vbYes Then
Call ClearExceptionTable
Call RunExceptionTable
End If
If YNMess = vbNo Then
Call RunExceptionTable
End If
End Sub
Private Sub RunExceptionTable()
Dim Rs As DAO.Recordset 'recordset for list of names from VcWAuditUsers
Dim db As DAO.Database
Dim SQL As String
Dim sTableName As String
Dim serverName As String
Dim dbName As String
Dim strUserCnt As Integer
Dim UserName As Variant
Dim StrSql As String
Dim ExceptStat As String
On Error GoTo ErrHandler
Dim iim1, iret
' Creates iMacros object and gives the starting webpage
Set iim1 = CreateObject("imacros")
iret = iim1.iimInit
iret = iim1.iimPlayCode("URL GOTO=https://www.sam.gov/)
'Sets the source table name
sTableName = "[SourceTable]"
'Sets the SQL string to grab the names of people to be inserted into website input section
SQL = "Select Distinct FName, LName from " & sTableName
'Starts the recordset for the source table and recordset
Set db = CurrentDb
Set Rs = db.OpenRecordset(SQL)
'resets the RS to start at the begining
If (Not Rs.EOF And Not Rs.BOF) Then
Rs.MoveLast
Rs.MoveFirst
'Grabs the total record count to use for end user messaging.
strUserCnt = Rs.recordCount
'MsgBox ("Number of rows: " & strUserCnt)
'Opens RS and starts while loop to open first record of the source table
With Rs
Do While (Rs.EOF = False)
'Creates new UserName by combining first and last name
UserName = Trim(![FName]) & " " & Trim(![LName])
'MsgBox ("New Name: " & UserName)
'set iMacros variables This subs the spot in the iMacros code where you manually entered information (there should be {{USERNAME}} in the iMacros where you want to enter data.
iret = iim1.iimSet("USERNAME", UserName)
'Plays the iMacro you recorded and altered earlier.
iret = iim1.iimPlay("Location of your iMacros goes here.iim")
'Checks for errors in the iMacros(anything in the negative is considered an error)
If iret < 0 Then
MsgBox iim1.iimGetLastError()
End If
'grabs the extracted data from recorded iMacro. the extracted data is stored in an (1) based array. Makes substitutions for the text that it extracts to convert to 1 or 0
If Left(iim1.iimGetExtract(1), 2) = "No" Then
ExceptStat = 0
Else
ExceptStat = 1
End If
'For each record in the source the extracted data is entered into the insert statement below along with the employee name and date. then warnings are suppressed and each is inserted into a local access table, Loop and move to the next.
StrSql = "Insert Into ExceptionResults Values('" & UserName & "'," & ExceptStat & ",'" & Now & "')"
DoCmd.SetWarnings False
DoCmd.RunSQL (StrSql)
DoCmd.SetWarnings True
.MoveNext
Loop
End With
MsgBox ("ExceptionResults table is complete and has " & strUserCnt & " Records")
'Clean up
Rs.Close
db.Close
End If
'Clean up
Set db = CurrentDb
Set Rs = db.OpenRecordset(SQL)
Set iim1 = Nothing
strUserCnt = 0
ErrHandler:
MsgBox "ERROR" & vbCrLf & Err.Description, vbCritical, "CmdGetExceptions"
End Sub
Private Sub ClearExceptionTable()
Dim StrSql2 As String
StrSql2 = "Delete from ExceptionResults"
DoCmd.SetWarnings False
DoCmd.RunSQL (StrSql2)
DoCmd.SetWarnings True
MsgBox ("All records from ExceptionResults have been truncated")
End Sub

VBA Access get string from db

I have a table with a column contain email addresses.
I would like to get these email addresses and send mail to them.
My problem is that i don't know how to get the addresses.
I would like to get a string as
me#email.com;me2#email.com;me3#email.com...etc
How can i get this string in order to pass it to the recipents?
From memory (not tested):
Dim db As DAO.Database, rs As DAO.Recordset
Dim s As String
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT email FROM myTable WHERE ...")
Do While Not rs.EOF
If s = "" Then
s = rs!email
Else
s = s & ";" & rs!email
End If
rs.MoveNext
Loop
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing
Since concatenating strings from a query is a frequent task, I suggest creating a reusable Function:
Public Function ConcatenateFromSql(ByVal sql As String, _
Optional ByVal delimiter As String = ";") As String
Dim db As DAO.Database, rs As DAO.Recordset
Dim s As String
Set db = CurrentDb
Set rs = db.OpenRecordset(sql)
Do While Not rs.EOF
If s = "" Then
s = rs(0)
Else
s = s & delimiter & rs(0)
End If
rs.MoveNext
Loop
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing
ConcatenateFromSql = s
End Function

Pass Parameter Query Def

The following code executes a stored procedure pass through query. The paramter is received fromthe form and is passed to the stored procedure. The error says that it is an invalid SQL Statement. I need to know if the code is right and how you connect to the database. The results are returned in a record set. Thanks!
Private Sub Command10_Click()
Dim rs1 As DAO.Recordset
Dim DB As Database
Dim Q As QueryDef
Dim strSQL As String
Set DB = CurrentDb()
Set Q = DB.QueryDefs("Call_SP")
strSQL = "execute dbo.ix_spc_planogram_match " & [Forms]![start]![Selection]![cat_code]
Q.ReturnsRecords = True
Q.SQL = strSQL
Set rs1 = DB.OpenRecordset(strSQL)
Do While Not rs1.EOF
Debug.Print rs1.Fields.Item("POG_DBKEY").Value = "POG_DBKEY"
Debug.Print rs1.Fields.Item("COMP_POG_DBKEY").Value = "COMP_POG_DBKEY"
Debug.Print rs1.Fields.Item("CURR_SKU_CNT").Value = "CURR_SKU_CNT"
Debug.Print rs1.Fields.Item("COMP_SKU_CNT").Value = "COMP_SKU_CNT"
Debug.Print rs1.Fields.Item("SKU_TOTAL").Value = "SKU_TOTAL"
Debug.Print rs1.Fields.Item("MATCHD").Value = "MATCHD"
rs1.MoveNext
Loop
rs1.Close
Set rs1 = Nothing
Set rs1 = Nothing
End Sub
CurrentDB is MS Access, but you are executing an SQL Server stored procedure. You need to execute against a connection to the server.
For example:
Dim objcon As New ADODB.Connection
scn = "Provider=sqloledb;Data Source=ServerName;" _
& "Initial Catalog=DBNAME;User Id=USERNAME;Password=Password;"
objcon.Open scn
Set rs = objcon.Execute