Операция Excel VBA Runtime 3704 не разрешена при закрытии объекта

#sql-server #excel #vba #stored-procedures

#sql-сервер #преуспеть #vba #хранимые процедуры

Вопрос:

Я использую этот код уже некоторое время, и он работает. На самом деле это работает с базовым запросом. Это просто не работает с моей новой хранимой процедурой. Я могу запустить хранимую процедуру вручную. в SSMS и получите мои результаты. Я думал, что ошибка была, когда я не получал данные обратно, поэтому я добавил . , , Если myRS1.EOF Тогда … все еще получаю ошибку времени выполнения 3704.

Вот мой код Excel (2013)

 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 '" amp; myStartDate amp; "', '" amp; myEndDate amp; "', '" amp; myInsuranceCode amp; "'"
    '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://" amp; 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 " amp; 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 " amp; 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 




 

*** Теперь это весь код VBA. Он терпит неудачу в строке myRS1.EOF, поэтому ни один другой код даже не запускается.

Как вы можете видеть, у меня есть два оператора MySQL. Первый не работает, но второй работает без проблем.

Если я запускаю SP из SSMS или даже беру сгенерированный MySQL, он отлично работает в SSMS.

Вот этот 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
 

Комментарии:

1. Остальную часть кода, пожалуйста

2. Добавлен сброс кода VBA. Сбой в файле myRS1.EOF, а остальная часть кода даже не выполняется.

3. Попробуйте параметризовать команду. Вы в любом случае должны это сделать из-за SQL-инъекции

4. Добавить SET NOCOUNT ON; в код процедуры.

5. Вы можете проверить состояние набора записей, чтобы узнать, открыт он или нет, используя If myRS1.State = adStateOpen Также вы можете проверить свойство Errors объекта connection, чтобы узнать, вызвал ли ваш вызов какие-либо ошибки docs.microsoft.com/en-us/sql/ado/guide/data /…