VBA 宏将 SQL 查询保存在 csv 文件中

Question

我正在开发一个 VBA 宏，它连接到我在 SQL Server 上的数据库并运行一些查询并将结果保存在 CSV 文件中......它在查询返回数据时工作正常，但我有几天查询没有t 返回任何结果，只是一个空表。我根据检查日期做了一个临时解决方案，并根据它宏运行该查询或不运行该查询...我现在想在我的代码中以其他方式进行操作，这样我就不需要每次手动更改日期...

我尝试了这些解决方案：

If (objMyRecordset.EOF = False) Or (objMyRecordset.BOF = False) Then

还有这个

If objMyRecordset.RecordCount <> 0 Then

但问题是我的 Recordset 是空的，因为查询没有返回任何行，所以它在 objMyRecordset.Open 中显示错误 例如，我想添加一行这样的代码：

'// Pseudo Code
If (the query doesn't return result)  Then 
    ( just the headers will be save on my file )
Else 
    (do the rest of my code)
End If

---

这是我的代码。请问有什么建议吗？非常感谢。

Sub Load_after_cutoff_queryCSV()

    Dim objMyConn As ADODB.Connection
    Dim objMyCmd As ADODB.Command
    Dim objMyRecordset As ADODB.Recordset

    Dim fields As String
    Dim i As Integer

    Set objMyConn = New ADODB.Connection
    Set objMyCmd = New ADODB.Command
    Set objMyRecordset = New ADODB.Recordset

'Open Connection
    objMyConn.ConnectionString = "Provider=SQLOLEDB;Data Source=*****;User ID=*****;Password=*****;"
    objMyConn.Open

'Set and Excecute SQL Command
    Set objMyCmd.ActiveConnection = objMyConn

    objMyCmd.CommandText = "SELECT * FROM [vw_X86_LOAD_AFTER_CUTOFF_REPORT_GAMMA]"

    objMyCmd.CommandType = adCmdText

'Open Recordset
    Set objMyRecordset.Source = objMyCmd

    objMyRecordset.Open

    Workbooks.Open Filename:="C:\Reports\load_after_cutoff_postGamma.csv"
    Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Activate
    ActiveSheet.Range("A2").CopyFromRecordset objMyRecordset

     For i = 0 To objMyRecordset.fields.Count - 1
    Worksheets("load_after_cutoff_postGamma").Cells(1, i + 1) = objMyRecordset.fields(i).name
    Next i

    Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Cells.EntireColumn.AutoFit

    Workbooks("load_after_cutoff_postGamma.csv").Close SaveChanges:=True
    MsgBox "Your file has been saved as load_after_cutoff_postGamma.csv"

Answer 1

如果您在连接到服务器时遇到问题，那么这是由于以下任一原因：

1. 连接字符串不正确
2. 凭据不正确
3. 服务器不可达（例如：网线断开）
4. 服务器未启动并运行

向服务器发送一个导致空记录集的查询不是ADODB.Connection 失败的原因。

这里有一些代码供您尝试在第一步中调试连接，然后在第二步中进行查询：

Option Explicit

Public Sub tmpSO()

Dim strSQL As String
Dim strServer As String
Dim strDatabase As String
Dim OutMail As Outlook.MailItem
Dim rstResult As ADODB.Recordset
Dim conServer As ADODB.Connection
Dim OutApp As Outlook.Application

strServer = "."
strDatabase = "master"

Set conServer = New ADODB.Connection
conServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
    & "DATA SOURCE=" & strServer & ";" _
    & "INITIAL CATALOG=" & strDatabase & ";" _
    & "User ID='UserNameWrappedInSingleQuotes'; " _
    & "Password='PasswordWrappedInSingleQuotes'; "
On Error GoTo SQL_ConnectionError
conServer.Open
On Error GoTo 0

strSQL = "set nocount on; "
strSQL = strSQL & "select  * "
strSQL = strSQL & "from    sys.tables as t "
strSQL = strSQL & "where   t.name = ''; "

Set rstResult = New ADODB.Recordset
rstResult.ActiveConnection = conServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0

If Not rstResult.EOF And Not rstResult.BOF Then
    ThisWorkbook.Worksheets(1).Range("A1").CopyFromRecordset rstResult
'    While Not rstResult.EOF And Not rstResult.BOF
'        'do something
'        rstResult.MoveNext
'    Wend
Else
    'https://msdn.microsoft.com/en-us/library/windows/desktop/ms675546(v=vs.85).aspx
    Select Case conServer.State
        'adStateClosed
        Case 0
            MsgBox "The connection to the server is closed."
        'adStateOpen
        Case 1
            MsgBox "The connection is open but the query did not return any data."
        'adStateConnecting
        Case 2
            MsgBox "Connecting..."
        'adStateExecuting
        Case 4
            MsgBox "Executing..."
        'adStateFetching
        Case 8
            MsgBox "Fetching..."
        Case Else
            MsgBox conServer.State
        End Select
End If

Set rstResult = Nothing

Exit Sub

SQL_ConnectionError:
MsgBox "Couldn't connect to the server. Please make sure that you have a working connection to the server."

Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .Subject = "Problems connecting to database '" & strDatabase & "' hosted on the server '" & strServer & "'"
    .HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
            "</span><br><br>Error report from the file '" & _
            "<span style=""color:blue"">" & ThisWorkbook.Name & _
            "</span>' located and saved on '<span style=""color:blue"">" & _
            ThisWorkbook.Path & "</span>'.<br>" & _
            "Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
            "Computer Name:    <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
            "Logged in as:     <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
            "Domain Server:    <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
            "User DNS Domain:  <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
            "Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
            "Excel Version:    <span style=""color:green;"">" & Application.Version & "</span><br>" & _
            "<br><span style=""font-size:10px""><br>" & _
            "<br><br>---Automatically generated Error-Email---"
    .Display
End With
Set OutMail = Nothing
Set OutApp = Nothing

Exit Sub

SQL_StatementError:
MsgBox "There seems to be a problem with the SQL Syntax in the programming."

Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .Subject = "Problems with the SQL Syntax in file '" & ThisWorkbook.Name & "'."
    .HTMLBody = "<span style=""font-size:10px"">" & _
            "---Automatically generated Error-Email---" & _
            "</span><br><br>" & _
            "Error report from the file '" & _
            "<span style=""color:blue"">" & _
            ActiveWorkbook.Name & _
            "</span>" & _
            "' located and saved on '" & _
            "<span style=""color:blue"">" & _
            ActiveWorkbook.Path & _
            "</span>" & _
            "'.<br>" & _
            "It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
            "SQL-Code causing the problems:" & _
            "<br><br><span style=""color:green;"">" & _
            strSQL & _
            "</span><br><br><span style=""font-size:10px"">" & _
            "---Automatically generated Error-Email---"
    .Display
End With
Set OutMail = Nothing
Set OutApp = Nothing

Exit Sub

End Sub

请注意，上面的代码清楚地区分了（首先）连接到服务器，然后（之后）向服务器发出查询以检索一些数据。这两个步骤是分开的，并且每种情况都有不同的错误处理程序。

此外，上面的示例代码还会导致返回一个空记录集。但是代码能够使用另一个错误处理程序来处理该事件。

如果连接失败或发送到服务器的 SQL 语法包含错误，则上述代码将自动生成错误电子邮件（使用 Outlook），其中包含一些详细信息供您检查连接和 SQL 语法。

Answer 2

您应该使用.EOF 解决方案。这是我的一个例子，我经常使用它。

Sub AnySub()

    ''recordsets
    Dim rec as ADODB.Recordset

    ''build your query here
    sSql = "SELECT * FROM mytable where 1=0" ''just to have no results

    ''Fire query
    Set rec = GetRecordset(sSql, mycnxnstring)

    ''and then loop throug your results, if there are any
    While rec.EOF = False

        ''do something with rec()
        rec.MoveNext
    Wend
End sub

这里的函数GetRecordset()由以下给出：

Function GetRecordset(strQuery As String, connstring As String) As Recordset
    Dim DB As ADODB.Connection
    Dim rs As ADODB.Recordset
    Set DB = New ADODB.Connection
    With DB
        .CommandTimeout = 300
        .ConnectionString = connstring
        .Open
    End With
    Set GetRecordset = DB.Execute(strQuery)

End Function

希望这会有所帮助。