Excel 2010 crashing on a macro that ran in 07 1

[rinzana]

Hello,

My company recently migrated to Windows 7 and Excel 2010, the below macro used to work in Windows XP and Excel 07. The first time the macro is run I get a:
"Microsoft Visual Basic
run-time error '-2147467249 (80004005)':
Query timeout expired

Here is the code:
Sub ImportMacola()

Worksheets("BMB").Range("A2:I10000").ClearContents
Worksheets("RMN").Range("A2:I10000").ClearContents
Worksheets("FFD").Range("A2:I10000").ClearContents
Worksheets("TUM").Range("A2:I10000").ClearContents
Worksheets("MTV").Range("A2:I10000").ClearContents


Call ImportPaperVisionMacolaData("data_04", DateInMacolaFormat(Sheet1.Range("startdate").Value), DateInMacolaFormat(Sheet1.Range("enddate").Value))
Call ImportPaperVisionMacolaData("data_03", DateInMacolaFormat(Sheet1.Range("startdate").Value), DateInMacolaFormat(Sheet1.Range("enddate").Value))
Call ImportPaperVisionMacolaData("data_005", DateInMacolaFormat(Sheet1.Range("startdate").Value), DateInMacolaFormat(Sheet1.Range("enddate").Value))
Call ImportPaperVisionMacolaData("data_006", DateInMacolaFormat(Sheet1.Range("startdate").Value), DateInMacolaFormat(Sheet1.Range("enddate").Value))
Call ImportPaperVisionMacolaData("data_07", DateInMacolaFormat(Sheet1.Range("startdate").Value), DateInMacolaFormat(Sheet1.Range("enddate").Value))
End Sub



Private Sub ImportPaperVisionMacolaData(str_CATALOG As String, str_StartDate As String, str_EndDate As String)
' Create a connection object.
Dim cnPubs As ADODB.Connection
Set cnPubs = New ADODB.Connection
Dim intRecCount As Integer

' Provide the connection string.
Dim strConn As String

'Use the SQL Server OLE DB Provider.
strConn = "PROVIDER=SQLOLEDB;"

'Connect to the Pubs database on the local server.
strConn = strConn & "DATA SOURCE=NJEDIMAC02;INITIAL CATALOG=" & str_CATALOG & ";"

'Use an integrated login.
'strConn = strConn & " INTEGRATED SECURITY=sspi;"
strConn = strConn & " User ID=papervision;Password=XXXXXXXX;"

'Now open the connection.
cnPubs.Open strConn


Dim rsPubs As ADODB.Recordset
Set rsPubs = New ADODB.Recordset

With rsPubs
' Assign the Connection object.
.ActiveConnection = cnPubs
' Extract the required records.
.Open "SELECT cus_no AS 'CUSTOMER #'" & _
" ,loc_desc AS 'STOCKING LOC'" & _
" ,bill_to_name AS 'CUSTOMER NAME'" & _
" ,oe_po_no AS 'PO #'" & _
" ,cast(cast(ord_no as integer) as varchar(8)) AS 'ORDER #'" & _
" ,inv_no AS 'INVOICE #'" & _
" ,cast(substring(cast(inv_dt as varchar(8)),5,2) + '/' + substring(cast(inv_dt as varchar(8)),7,2) + '/' + substring(cast(inv_dt as varchar(8)),1,4)as varchar(10)) AS 'INVOICE DATE'" & _
" ,cast('$' + cast(tot_dollars as varchar(20)) as varchar(20)) AS 'INVOICE AMT'" & _
" FROM oehdrhst_sql AS OHH" & _
" LEFT OUTER JOIN IMLOCFIL_SQL ON mfg_loc = loc " & _
" WHERE inv_dt BETWEEN '" & str_StartDate & "' and '" & str_EndDate & "'" & _
" ORDER BY inv_no", , adOpenDynamic



Select Case str_CATALOG
Case "data_04"
Sheet2.Range("A2").CopyFromRecordset rsPubs
If Not rsPubs.BOF Then
rsPubs.MoveFirst
End If
If Not rsPubs.EOF Then
While Not rsPubs.EOF
intRecCount = intRecCount + 1
Sheet2.Cells(intRecCount + 1, 9).Value = intRecCount
rsPubs.MoveNext
Wend
rsPubs.MoveFirst
End If
Case "data_03"
Sheet3.Range("A2").CopyFromRecordset rsPubs
If Not rsPubs.BOF Then
rsPubs.MoveFirst
End If
If Not rsPubs.EOF Then
While Not rsPubs.EOF
intRecCount = intRecCount + 1
Sheet3.Cells(intRecCount + 1, 9).Value = intRecCount
rsPubs.MoveNext
Wend
rsPubs.MoveFirst
End If
Case "data_005"
Sheet4.Range("A2").CopyFromRecordset rsPubs
If Not rsPubs.BOF Then
rsPubs.MoveFirst
End If
If Not rsPubs.EOF Then
While Not rsPubs.EOF
intRecCount = intRecCount + 1
Sheet4.Cells(intRecCount + 1, 9).Value = intRecCount
rsPubs.MoveNext
Wend
rsPubs.MoveFirst
End If
Case "data_006"
Sheet5.Range("A2").CopyFromRecordset rsPubs
If Not rsPubs.BOF Then
rsPubs.MoveFirst
End If
If Not rsPubs.EOF Then
While Not rsPubs.EOF
intRecCount = intRecCount + 1
Sheet5.Cells(intRecCount + 1, 9).Value = intRecCount
rsPubs.MoveNext
Wend
rsPubs.MoveFirst
End If
Case "data_07"
Sheet6.Range("A2").CopyFromRecordset rsPubs
If Not rsPubs.BOF Then
rsPubs.MoveFirst
End If
If Not rsPubs.EOF Then
While Not rsPubs.EOF
intRecCount = intRecCount + 1
Sheet6.Cells(intRecCount + 1, 9).Value = intRecCount
rsPubs.MoveNext
Wend
rsPubs.MoveFirst
End If
End Select

' Tidy up
.Close
End With


cnPubs.Close
Set rsPubs = Nothing
Set cnPubs = Nothing


End Sub

Private Function DateInMacolaFormat(dat) As String
DateInMacolaFormat = Format(dat, "yyyy") & Format(dat, "mm") & Format(dat, "dd")
End Function

If I change the password and intentionally crash the macro, then fix the password and run it again, it works.
The dubugger is pointing to this line:
Sheet2.Range("A2").CopyFromRecordset rsPubs

I do understand the timeoput message, but when the macro runs, it only tales 4 seconds of query time.
Any suggestions?

Thanks Rich

 

[SkipVought]

hi,

Do you have a sheet with the CodeName of Sheet2. You can ONLY determine in the VB Editor, looking at the PROJECT (ctr+R)

BTW, Excel code (VBA) questions are best addressed in forum707.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[rinzana]

Hi Skip,

I have attached a print screen. I think this will answer your question. I did not write the macro or the VBA code.

 

[rinzana]

http://www.strawbridgepta.org/public_html/VBA

print screen1.png

 

[rinzana]

Well that doesn't appear to work the print screen states:
Microsoft Excel Objects
Sheet1 (Sheet1)
Sheet2 (BMB)
Sheet3 (RNM)
Sheet4 (FFD)
Sheet5 (TUM)
Sheet6 (MTV)
ThisWorkbook

Thanks Again
Rich

 

[SkipVought]

Well Sheet2 exists, so that reference is not the problem.

The next place to look is rsPubs

Use the technique described in faq707-4594 to discover what's going on with this recordset object. Look for the BOF & EOF properties.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[rinzana]

I have no idea what this means:
object, object group or variable and Add Watches

 

[SkipVought]

Welcome to the world of VBA and coding. ;-)

You will either have to slog thru this learning process (and folks here will try to help you thru the process), or you can hire a geek to fix your problem.

.......

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[rinzana]

This does not explain why it works after I intentionally break it and then fix it by changing the password. I was looking to get some specific OLE/Excel 10 help. The code works just fine, just it isn't logging into the database when the workbook is initially opened. Changing the database password to something incorrect and getting an login error, then fixing the password seems to fix whatever the issue is.

 

[SkipVought]

Well if you are NOT logged in, the recordset object will be EMPTY and will raise an error.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[rinzana]

??? The id and password for the database are in the script. Here is the scenario in order to make this work in Excel 2010. Openthe workbook, change dates which will affect the query. Press the button to run the macro, get the Timeout error above, click debug and remove a character from the databse login password. Close the debugger, and run the macro again, get a login error, open the debugger and add in the character you just deleted from the password. Close the debugger and run the macro - it will work fine.
Honestly, I'm at a loss, the SQL DBA is at a loss and the VB programmer is at a loss.
The macro runs just fine in Excel 07, and we have had to set up an instance of Excel 07 in Citrix so users can run this macro.

Rich

 

[SkipVought]

I certainly, cannot add any more insight than your DBA or VB programmer. They are the most logical and qualified resources at your disposal.

Timeout??? Hmmmmmm?

Just for grins, try removing the SEMICOLON after the password[/b ] in your connect string and see it if runs in 2010. It's a long shot!

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]