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

Question

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

我尝试这些解决方案：

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

而且这个

If objMyRecordset.RecordCount <> 0 Then 

但问题是，我的记录是空的，因为查询不返回任何行，所以它让我错误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. 服务器未启动并运行

发送查询吨o导致空记录集的服务器是而不是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解决方案。这是我经常使用的一个例子。

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 

希望这有助于：

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()由下式给出。