I have a VBA sub in Excel. It needs to call a SQL Server procedure, and display the results of the call in a message box. (Mainly, because I'm maintaining someone else's code - otherwise, I wouldn't be using Excel.)
I create my SQL statement to call the procedure. I have subs that open the connection. But I'm still missing something in the process of showing the results of that procedure call.
Here's what I have so far:
Dim Today As Date
Dim result As Date
Dim sSQLStatement As String
Dim strDate As String
Dim Recordset As ADODB.Recordset
Today = DateTime.Now()
result = DateSerial(Year(Today), Month(Today) - 1, 1)
strDate = Year(result) & "-" & Format(Month(result), "00") & "-" & Format(Day(result), "00")
DBOpen
sSQLStatement = "set nocount on; EXEC [MySchema].[dbo].[MyProcedure] #END_DATE = N'" & strDate & "'"
MsgBox sSQLStatement
Dim i As Long
Dim Ary
Dim strMsg As String
Set Recordset = New ADODB.Recordset
With Recordset
.ActiveConnection = cnPubs 'this is defined elsewhere, used in the DBOpen call, and works
'I can call the execute and it works, but it fails here when I try to assign the results to the recordset
Recordset = cnPubs.Execute(sSQLStatement)
'I found this online and don't know yet if it works. I have to get past the statement above first.
If Not Recordset.EOF Then
Ary = Recordset.GetRows
For i = 0 To UBound(Ary, 2)
If i = 0 Then
strMsg = Ary(0, i)
Else
strMsg = strMsg & ", " & Ary(0, i)
End If
Next i
MsgBox strMsg, , UBound(Ary, 2) + 1 & " records"
End If
.Close
End With
DBClose
So, if I call the cnPubs.Execute(sSQLStatement) by itself, I can tell it is running. I open and close the connection just fine. But it should be returning a set of several rows, and I need to display that. I don't want to write those to the spreadsheet anywhere - they should just be displayed in a message box.
Change
Recordset = cnPubs.Execute(sSQLStatement)
to
recordset.open sSQLStatement, cnPubs
Related
I have been using this code for some time and it works. As a matter of fact it works with a basic query. It just does not work with my new Stored Procedure. I can run the stored procedure manually. in SSMS and get my results. I thought that the error was when I was not getting data back so I added the . . . If myRS1.EOF Then . . . still getting the 3704 runtime error.
Here is my Excel (2013) Code
Private Sub cmdOK_Click()
Dim myStartDate, myEndDate
Dim myInsuranceCode
Dim objAD, objUser
Dim myDisplayName, myLastRow
Dim myMessage, myStyle, myTitle, myResult
Dim mySQL As String
Dim myConn
Dim myCmd
Dim myRS1
Dim myRange, myNamedRange, myCheckRange As Range
Dim X, Y, z
Dim myPercent, myLowEnd, myHighEnd
Dim myValue1, myValue2, myValue3, myValue4, myValue5, myValue6, myValue7, myValue8
Dim myCheckValue
Dim myHeaderRow, myDataRow, myLastColumn
'SET THESE ACCORDING TO THE REPORT. THE FIRST TWO MIGHT NOT NEED ANY CHANGES
myHeaderRow = 2
myDataRow = 3
myLastColumn = 22
'SETUP DATABASE OBJECTS
Set myConn = New ADODB.Connection
Set myCmd = New ADODB.Command
Set myRS1 = New ADODB.Recordset
Application.StatusBar = True
Application.StatusBar = "Connecting to SQL Server"
'GET DATES FROM TEH FORM AND SET SQL STATEMENT
myStartDate = frmMain.txtStartDate
myEndDate = frmMain.txtEndDate
'RUN INSURANCE STORE PROCEDURE
'SEPERATE THE INSURANCE CODE WITH A |
myInsuranceCode = "S19|S22"
mySQL = "dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '" & myStartDate & "', '" & myEndDate & "', '" & myInsuranceCode & "'"
'mySQL = "SELECT * FROM dbo.BETHESDA_ADMIT_SOURCE"
'HIDE THE FORM
frmMain.Hide
'GET THE USER THAT IS SIGNED IN
Set objAD = CreateObject("ADSystemInfo")
Set objUser = GetObject("LDAP://" & objAD.UserName)
myDisplayName = objUser.DisplayName
'OPEN CONNECTIONS TO THE DATABASE
myConn.ConnectionString = "Provider=SQLOLEDB;Data Source=mySQLServer;Initial Catalog=myDatabaseName;User ID=user;Password=xxxxxxxx;Connection Timeout=300;"
myConn.Open
'SET AND EXECUTE SQL COMMAND
Set myCmd.ActiveConnection = myConn
myCmd.CommandText = mySQL
myCmd.CommandType = adCmdText
Application.StatusBar = "Running Stored Procedure " & mySQL
myCmd.CommandTimeout = 3000
'OPEN RECORDSET
Set myRS1.Source = myCmd
myRS1.Open
'CHECK TO MAKE SURE WE ARE NOT AT THE BOTTOM OF THE SHEET COULD MEAN THERE WAS NOT DATA LAST TIME.
'THIS SAME CODE WILL REPEAT FOR THE DATA TAB
'*********** DATA *************
'CHECK TO MAKE SURE THERE IS DATA
If myRS1.EOF Then <---- THIS IS THE LINE I AM GETTING THE ERROR
Cells(myDataRow, 1).Value = "No Data Qualifies"
myMessage = "No data qualifing for your request " & mySQL
myTitle = "No Data"
myStyle = vbCritical + vbOKOnly
myResult = MsgBox(myMessage, myStyle, myTitle)
Exit Sub
End If
'SELECT THE SHEET TO CLEAR OUT THE OLD data on DATA
'IF THIS IS NOT SET ON THE SEEHET IT WILL FAIL
Set myTable = Sheets("DATA").ListObjects("DATA")
If Cells(myDataRow, 1).Value <> "" Then
myTable.DataBodyRange.Rows.Delete
End If
'COPY THE DATA TO EXCEL
Application.StatusBar = "Copying the new data."
Sheets("DATA").Cells(myDataRow, 1).CopyFromRecordset myRS1
Cells(1048576, 1).Select
Selection.End(xlUp).Select
myLastRow = ActiveCell.Row
'Application.StatusBar = "Naming the new DATA range"
'ActiveWorkbook.Names.Add Name:=myNamedRange, RefersTo:=Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
myTable.Resize Range(Cells(myHeaderRow, 1), Cells(myLastRow, myLastColumn))
End Sub
*** This is all the VBA Code now. It is failing on the myRS1.EOF line so none of the other code even runs.
As you can see I have two mySQL statements. The first one is not working, but the second one works no issue.
If I run the SP from SSMS or even take the mySQL that is generated it runs fine in SSMS.
Here is the SP
--EXAMPLE
-- dbo.BMH_rpt_PATIENTS_INSURANCE_LISTING '11/01/2020', '11/30/2020', 'S19|S22'
ALTER PROCEDURE [dbo].[BMH_rpt_PATIENTS_INSURANCE_LISTING]
#StartDate AS DATETIME,
#EndDate AS DATETIME,
#Insurance AS VARCHAR(MAX)
AS
/** GET THE INSURANCE CODES **/
SELECT VALUE
INTO #INSURANCE
FROM STRING_SPLIT(#Insurance, '|')
/** GET THE PATIENTS FOR THE LIST **/
SELECT vv.pt_id AS 'Patient Account',
vv.alt_med_rec_no AS 'MRN'
FROM smsdss.vst_v AS vv
WHERE vv.pyr_cd IN (SELECT * FROM #INSURANCE)
AND vv.start_full_date BETWEEN #StartDate AND #EndDate
AND vv.tot_bal_amt <> 0
I'm start to do programming in Access, and I really need help!!
My objective is to create a module that is run in "tbCustoProjeto" table and rewrite the field "Valor HH" values based on Dlookup. I found some solution (by azurous) who I think will solve this, but when I run the code, is returned
"object-required-error".
Sub redefineHH()
Dim objRecordset As ADODB.Recordset
Set objRecordset = New ADODB.Recordset
Dim i As Integer
Dim value As Variant
Dim HHTotal As Double
Set HHTotal = DLookup("[CustoTotalNivel]", "tbNivelNome2", "nUsuario='" & tbCustoProjeto!NumUsuario & "'" & "AND Numeric<=" & tbCustoProjeto!DataNumero)
'initated recordset obejct
objRecordset.ActiveConnection = CurrentProject.Connection
Call objRecordset.Open("tbCustoProjeto", , , adLockBatchOptimistic)
'find the target record
While objRecordset.EOF = False
'If objRecordset.Fields.Item(13).value > 0 Then
objRecordset.Fields.Item(13).value = HHTotal
objRecordset.UpdateBatch
'exit loop
'objRecordset.MoveLast
objRecordset.MoveNext
'End If
Wend
MsgBox ("Pesquisa Finalizada")
End Sub
Print of tbCustoProjeto
Print of tbNivelNome2
Please, someone can tell me where is the error? I don't know what to do.
Cannot reference a table directly like that for dynamic parameter. DLookup should pull dynamic criteria from recordset and within loop. Don't use apostrophe delimiters for number type field parameter.
Remove unnecessary concatenation.
Sub redefineHH()
Dim objRecordset As ADODB.Recordset
Set objRecordset = New ADODB.Recordset
objRecordset.Open "tbCustoProjeto", CurrentProject.Connection, , adLockBatchOptimistic
While objRecordset.EOF = False
objRecordset.Fields.Item(13) = DLookup("[CustoTotalNivel]", "tbNivelNome2", _
"nUsuario=" & objRecordset!NumUsuario & " AND Numeric <=" & objRecordset!DataNumero)
objRecordset.UpdateBatch
objRecordset.MoveNext
Wend
MsgBox ("Pesquisa Finalizada")
End Sub
I want to be able to execute a SQL Server stored procedure from MS Access VBA, in such a way that I can read (1) all the resulting result sets, not just the first one; and (2) any messages produced by PRINT statements or similar.
I have a test stored procedure with one input parameter, which produces 3 distinct result sets and about 90 messages. It calls several sub-stored procedures, I can EXEC it perfectly well from SSMS, but it isn’t clear (to me) how best to do it from Access VBA. I have tried the following so far:
DAO. Using SQL pass-through queries, I can get a lot of what I want in DAO, though it is a little clunky. It returns the first of the 3 result sets as a recordset, and by using the LogMessages attribute I can get a table (“Admin – NN”) containing the emitted messages.
ADO. Using Connection and Command objects, I can obtain a single recordset representing the first result set from the stored procedure. However, I can’t seem to persuade it to produce anything but a forward-only recordset. Regarding messages, at one point, all of them (at least, the first 127 of the approx. 150 I expected) were going into the connection’s Errors collection (!), but when I cut the number down to about 90, none of them appeared anywhere at all that I could find.
What I really want, as I said at first, is the output from all result sets, plus the messages. Is this possible?
Here is a listing of the routine I am currently using for executing a stored procedure :
Function ExecuteStoredProcedureADO(SPName As String, Connect As String, ReturnsRecords As Boolean, _
ParamArray Params() As Variant) As ADODB.Recordset
' v1.0 2018/06/26
' execute stored procedure SPName on a SQL Server database specified by the string in Connect
Dim strErr As String
Dim i As Integer
Dim lngRecsAffected As Long
Dim cnn As ADODB.Connection
Dim cmd As ADODB.Command
Dim errCurr As ADODB.Error
Dim rst As ADODB.Recordset
On Error GoTo Catch
Set ExecuteStoredProcedureADO = Nothing
Set cnn = New ADODB.Connection
cnn.Errors.Clear
cnn.mode = adModeRead
cnn.CommandTimeout = 300
cnn.Open Connect
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandText = SPName
.CommandType = adCmdStoredProc
For i = 0 To UBound(Params) Step 4
.Parameters.Append .CreateParameter(Params(i), Params(i + 1), adParamInput, Params(i + 2), Params(i + 3))
Next i
Set rst = New ADODB.Recordset
rst.CursorType = adOpenStatic
If ReturnsRecords Then
'''Set rst = .Execute(lngRecsAffected)
rst.Open cmd, , adOpenStatic, adLockReadOnly
Else
Set rst = .Execute(, , adExecuteNoRecords)
End If
End With
If ReturnsRecords Then Set ExecuteStoredProcedureADO = rst
Final:
On Error Resume Next
If Len(strErr) > 0 Then Call AppendMsg(strErr)
Set rst = Nothing
Set cmd = Nothing
Exit Function
Catch:
If cnn.Errors.Count > 0 Then
With cnn
For Each errCurr In cnn.Errors
strErr = strErr & "Error " & errCurr.Number & ": " & errCurr.Description _
& " (" & errCurr.Source & ")" & vbCrLf
Next errCurr
strErr = Left(strErr, Len(strErr) - 2) ' truncate final CRLF
End With
Else
strErr = "Error " & Err.Number & ": " & Err.Description & " (" & Err.Source & ")"
End If
MsgBox strErr, vbOKOnly, gtitle
Resume Final
End Function
Addendum: Regarding the multiple result sets, I am hoping that http://msdn.microsoft.com/en-us/library/ms677569%28VS.85%29.aspx
will be of some help.
To shamelessly piggy-back off of #Erik, you want to create a new class that will handle your processing. Something like cProcedureHandler. Within this class, you need to declare an ADODB.Connection object using the WithEvents keyword:
Dim WithEvents cn As ADODB.Connection
Then, you need to write a InfoMessage event handler that will take care of the multiple print statements. Information about the InfoMessage event can be found here, and using the connection's Errors collection can be found here. So you'll end up with something like this:
Private Sub cn_InfoMessage(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
Dim err As ADODB.Error
Debug.Print cn.Errors.Count & " errors"
For Each err In cn.Errors
' handle each error/message the way you need to.
Debug.Print err.Description
Next err
End Sub
Since you've taken care of the code to handle multiple messages, now you just need to handle the multiple recordsets, which is explained pretty well in the link you provided. One thing I noticed was that the example link used rs is nothing as the check for when there were no more recordsets, which didn't work for me. I had to use the rs State property. So I ended up with this:
Public Sub testProcedure()
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim recordSetIndex As Integer
Set cn = modData.getConnection
Set cmd = New ADODB.Command
cmd.ActiveConnection = cn
cmd.CommandType = adCmdStoredProc
cmd.CommandText = "dbo.sp_foo"
Set rs = cmd.Execute
recordSetIndex = 1
Do Until rs.State = ObjectStateEnum.adStateClosed
Debug.Print "contents of rs #" & recordIndex
Do Until rs.EOF
Debug.Print rs.Fields(0) & rs.Fields(1)
rs.MoveNext
Loop
Set rs = rs.NextRecordset
recordSetIndex = recordIndex + 1
Loop
cn.Close
Set rs = Nothing
Set cn = Nothing
Set cmd = Nothing
End Sub
Then, when you're ready to run your SP from VBA, just do something like this:
set obj = new cProcedureHandler
obj.testFooProcedure
Another thing (you probably have already done this): Make sure your actual stored procedure in SQL Server sets nocount on.
i have an ADODB recordset to load data from a view in an Excel sheet. The view is located in a MS SQL database. It runs perfectly for months, but since a few days the recordset is always empty, so i did not get any results. After a long day searching the www for any reasons i found, that it can happen because i use a x32 Excel and there is so much data in the view. So i separated the procedure in two queries. This helped a lot and the macro run perfectly again. Yesterday the same error appears again, so i began to split the procedure again. But now the recordset is still empty. I don't know any reason for this. I tested it with a selection of only ten rows of the view and this runs but if i want to get 1000 rows the recordset is empty again. Does anybody know a reason for this problem? All queries give the result i want to have in the database so they are ok.
Here is my code:
Sub doStuff()
Dim sqlStatement(9) As String
Dim lrow As Long
'... other variables
sqlStatement(1) = "Select * from db.View1 where location like 'forest'"
'... other sqlStatements
For i = 0 To UBound(sqlStatement)
Call loadData(sqlStatement, lrow)
Next i
End Sub
Sub loadData(sqlStatement As String, lastrow As Long)
Dim sqlServer As String
Dim dbName As String
sqlServer = "MSSQLSERVER"
dbName = "database"
On Error Resume Next
Dim con As Object
Set con = CreateObject("ADODB.Connection")
con.Open _
"Provider = sqloledb;" & _
"Data Source=" & sqlServer & ";" & _
"Initial Catalog=" & dbName & ";" & _
"User ID=user1;" & _
"Password=abcde;"
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
With rst
.ActiveConnection = con
.Open sqlStatement , con, adLockReadOnly
ws.Activate
If lastrow = 1 Then
For col = 0 To .Fields.Count - 1
ws.Cells(1, col + 1).Value = .Fields(col).Name
Next
End If
ws.Activate
ws.Cells(lastrow+1,1).CopyFromRecordset rst
.Close
End With
con.Close
Set rst = Nothing
Set con = Nothing
End Sub
I am trying to run SQL query on sql server (some DWH) and then insert outcome into access table (using VBA).
I did it by using ADODB.Connection, ADODB.Command and ADODB.Recordset. At this point I have my outcome in Recordset and I Wonder how I can insert it into table without looping it.
I tried:
If Not (Rs.EOF And Rs.BOF) Then
Rs.MoveFirst
Do Until Rs.EOF = True
DoCmd.RunSQL ("INSERT INTO Table (F1, F2) VALUES ( " & rs![F1] & ", " & rs[F2] & ")"
Rs.MoveNext
Loop
End If
But Recordset may have over 100k rows. So it would take ages to insert it by using this method.
Another very fast way is to open a new excel workbook paste it into worksheet and then import it. But I would like to avoid it. Is there any other way ?
---------EDITED-----------
Sorry guys. My bad. I was forcing solution with VBA while linkin it was perfect. THANKS !
I was wondering if there is any as fast way which use Access
resources only.
As already mentioned, link the SQL table, then create a simple append query that reads from the linked table and writes to your Access table, and you're done.
I agree with the commenters that you should link if at all possible. But I wanted to see if it could be done. I ended up converting the recordset to a comma delimited file and use TransferText to append it.
Public Sub ImportFromSQLSvr()
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Dim sResult As String
Dim sFile As String, lFile As Long
Const sIMPORTFILE As String = "TestImport.txt"
Set cn = New ADODB.Connection
cn.Open msCONN
Set rs = cn.Execute("SELECT SiteID, StoreNumber FROM Site")
'Add a header row, replace tabs with commas
sResult = rs.GetString
sResult = "SiteID, StoreNumber" & vbNewLine & sResult
sResult = Replace(sResult, vbTab, ",")
'Write to a text file
lFile = FreeFile
sFile = Environ("TEMP") & "\" & sIMPORTFILE
Open sFile For Output As lFile
Print #lFile, sResult
Close lFile
'Append to table dbo_Site
DoCmd.TransferText acImportDelim, , "dbo_Site", Environ("TEMP") & "\" & sIMPORTFILE, True
On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
If you have any commas in your data, you'll need to do some extra work to properly format the csv.