VBA: SQL Server / Query timeout

[dbmathis]

Hi all,

When running the following code I am seeing a 30 second timeout error. I get the error message: 'Timeout expired'. This doesn't happen in Query Analyzer? Is there a way to up the timeout roof or mask this error?

Private Sub CommandButton4_Click()

Dim listarray(), y(), x As Long, z As Long, header()
Dim i As Long, ii As Long, iii As Long, iv As Long, v As Long
Dim strConn As String, strSQL As String, ws1 As Worksheet
Dim conn As ADODB.Connection, lastr As Long, lastc As Long
Dim rst As ADODB.Recordset, n As String, dQuery As String
Set conn = New ADODB.Connection
Set ws1 = Sheets("Report")

If TextBox1 = "" Or TextBox2 = "" Then
    MsgBox "You must enter a start and end date.", 48, "Missing data."
    Exit Sub
End If

'If DateValue(TextBox2.Value) - DateValue(TextBox1.Value) >= 31 Then
'    MsgBox "You may not query more than 1 months worth of data", 48, "Query Too Big"
'    Exit Sub
'End If

strConn = "Provider=SQLOLEDB.1;" _
    & "Password=guess;" _
    & "User ID=operationsanalyst;" _
    & "Data Source=usaus-support3;" _
    & "Packet Size=4096;" _
    & "Initial Catalog=Data_Warehouse"
conn.Open strConn

For i = ListBox1.ListCount - 1 To 0 Step -1
    If ListBox1.Selected(i) Then
        ReDim Preserve listarray(i)
        listarray(i) = ListBox1.List(i)
        ii = ii + 1
        qryColumns = ListBox1.List(i) & ", " & qryColumns
    End If
Next

If ii < 1 Then
    MsgBox "You must choose at least 1 field", 48, "No fields are chosen."
    Exit Sub
End If

qryColumns = Left(Trim(qryColumns), Len(Trim(qryColumns)) - 1)

cbx1 = Format(TextBox1.Value, "m/dd/yyyy")
cbx2 = Format(TextBox2.Value, "m/dd/yyyy")

dQuery = "select " & qryColumns & " From vw_Union_All_Incidents" _
    & " where CST_OPEN_TIME >= " & Chr(39) & cbx1 & " 12:00:00 AM" & Chr(39) _
    & " and CST_OPEN_TIME <= " & Chr(39) & cbx2 & " 12:00:00 PM" & Chr(39) _
    & " and company = " & Chr(39) & ComboBox1.Value & Chr(39)
    
Set rst = conn.Execute(dQuery)
fcnt = rst.Fields.Count
       
If rst.EOF = True Then
    MsgBox "No results to display!"
    Exit Sub
End If

For i = 0 To rst.Fields.Count - 1
    ReDim Preserve header(i)
    header(i) = rst.Fields(i).Name
Next

'ws1.Range("b3").CopyFromRecordset rst

y = rst.GetRows

If UBound(y, 2) > 65500 Then
    MsgBox "Your resultset is larger than the excel sheet. Query aborted.", _
    48, "Query aborted!."
    Exit Sub
End If

ws1.Cells.ClearContents

ws1.Range("b3").Resize(LBound(header) + 1, UBound(header) + 1) = header

x = UBound(y, 1) + 1: z = UBound(y, 2) + 1

For i = 0 To fcnt - 1
    For ii = 0 To z - 1
        If IsDate(y(i, ii)) Then
            y(i, ii) = Format(y(i, ii))
        ElseIf IsArray(y(i, ii)) Then
            y(i, ii) = "Array Field"
        ElseIf y(i, ii) = 0 Then
            y(i, ii) = Empty
        End If
    Next
Next

' begin Transpose

ReDim trans(0 To UBound(y, 2), 0 To UBound(y, 1))
For i = 0 To UBound(y, 2)
    For ii = 0 To UBound(y, 1)
        trans(i, ii) = y(ii, i)
    Next
Next

' end transpose

ws1.Range("b4").Resize(UBound(trans, 1) + 1, UBound(trans, 2) + 1) = trans

Label6.Caption = UBound(trans, 1) & " Rows returned."

Me.Caption = UBound(trans, 1) & " Rows returned."

ws1.Range("b1") = "Company: " & ComboBox1 & "  Report interval: " & TextBox1 & " - " & TextBox2

If WorksheetFunction.CountA(Cells) > 0 Then
    lastc = Cells.Find(What:="*", After:=[A1], _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious).Column
    lastr = Cells.Find(What:="*", After:=[A1], _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
End If

ws1.Range(ws1.Cells(3, 2), ws1.Cells(300, lastc)).Columns.AutoFit

End Sub

 

[viquarshaikh]

use
conn.connectionTimeout

 

[MNpoker]

Anymore help on this?

I have the following code (In SQL analyzer this takes 49 seconds, though I do have another one that takes 15 minutes I will need later)

This has worked fine for every other queryt I've done in the past.

It does create the new Table in the proper place (with no data) so I'm sure I'm connecting OK.

Sub RunQueries()

' Runs The Report
' ----------------------------------------------------------------------------------------------
 

'Connect to Server
sServer = "OLEDB;Provider=SQLOLEDB.1;password=*****;Persist Security Info=True;User ID=**;Data Source=*****;Timeout=0"
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCommand = 1

Set ObjConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")
Set ObjCommand = CreateObject("ADODB.Command")

'Load EDM and PORTID Name
sRDM = Worksheets("Inputs").Range("B1")
sAnalysisID = Worksheets("Inputs").Range("B2")
sPeril = Worksheets("Inputs").Range("B8")
sPerspcode = Worksheets("Inputs").Range("B9")



' Open Connection
ObjConnection.Open = "Provider=SQLOLEDB;Data Source=" & sServer & ";Trusted_Connection=Yes;Initial Catalog=" & sRDM
    
ObjCommand.CommandType = adCommand
ObjCommand.ActiveConnection = ObjConnection


  
'CREATE AND RUN QUERIES

' Flaglist

VtSQL = "SELECT rdm_account.ID, 0 As FlagId " & _
"Into FlagList " & _
"FROM rdm_account " & _
"WHERE (((rdm_account.ANLSID)=" & sAnalysisID & ") AND ((rdm_account.PERSPCODE)='" & sPerspcode & "')) " & _
"Group By rdm_account.ID; "


ObjCommand.CommandText = VtSQL
ObjCommand.Execute


Set ObjConnection = Nothing
Set objRecordSet = Nothing
Set ObjCommand = Nothing

End Sub