I apologize in advance if this has been answered before. I searched for it but could not find anything explaining this particular issue.
I'm getting the OleDb exception 0x80004005 - Cannot open any more tables while reading a large Excel spreadsheet. It parses around 2000 records correctly than breaks.
I searched for this error, which is related to a limit of 2048 tables being open at a given time. I cannot see where my code is wrong, and I think it is, but I need a fresh pair of eyes looking at me to point me out what I'm missing.
This is the code - As you can see, I am closing the reader ReaderExcelProgramsColumn
What am I not seeing?
If strSpreadSheetFullPathLowCase.Contains(".xlsx") Then
strConnectionStringExtendedParameters = ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1;Mode=Read;Readonly=True"";"
ElseIf strSpreadSheetFullPathLowCase.Contains(".xlsm") Then
strConnectionStringExtendedParameters = ";Extended Properties=""Excel 12.0 Macro;HDR=YES;IMEX=1;Mode=Read;Readonly=True"";"
End If
Dim intColumStartLocator As Integer = 0
Dim strConnectionStringExcel = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & txtFilePathOpenExcel.Text & strConnectionStringExtendedParameters
Dim strProgramID As String = Nothing
Dim strMachinePrefix As String = Nothing
Dim strProgramFileExtensionFromExcel As String = Nothing
Dim strLastFileName As String = Nothing
Dim strLastProgramID As String = Nothing
Dim strFullFilePath As String = Nothing
Dim sqlExcelConnection As OleDbConnection = Nothing
Try
'/////////////////////////////////////////////
'// Open the connection with the Excel File //
'/////////////////////////////////////////////
lblStatus.Text = "Opening connection with MS-Excel..."
Application.DoEvents()
sqlExcelConnection = New OleDbConnection(strConnectionStringExcel)
sqlExcelConnection.Open()
Catch ex As Exception
If (sqlExcelConnection.State = ConnectionState.Open) Then
sqlExcelConnection.Dispose()
End If
ErrorToReadFromMSExcel(ex.ToString, System.Reflection.MethodInfo.GetCurrentMethod.ToString, True)
Exit Sub
End Try
Try
Dim strProgramsQuery As String = "SELECT" & vbNewLine &
"[" & cboxExcelCIMCODBFieldProgram.Text & "]" & vbNewLine &
"FROM [" & cboxExcelTabName.Text & "$]"
Dim Query As String = String.Empty
Dim sqlSelectColumnsExcelPrograms As New OleDbCommand(strProgramsQuery, sqlExcelConnection)
Dim ReaderExcelProgramsColumn As OleDbDataReader = sqlSelectColumnsExcelPrograms.ExecuteReader
Do While ReaderExcelProgramsColumn.Read()
If ReaderExcelProgramsColumn.HasRows Then
strProgramID = Trim(UCase(ReaderExcelProgramsColumn.GetValue(0).ToString))
Dim strQuery As String = "SELECT" & vbNewLine &
"hdrfullprefix" & vbNewLine &
"FROM " & strCustomNameForHeaderSettingsTable & " AS slb" & vbNewLine &
"INNER JOIN " & strTableMchGroups & " AS mg" & vbNewLine &
"WHERE mg." & strMchGroupID & " = slb.machidncbase" & vbNewLine &
"AND mg." & strMchGroup & " = '" & cboxCIMCOMachineToMigrate.Text & "'" & vbNewLine &
"ORDER BY id DESC" & vbNewLine &
"LIMIT 1"
strMachinePrefix = RunBasicQueryReturnIsStringOnNCBase(strNCBaseConnectionString, strQuery)
If strProgramID <> String.Empty Then
lblStatus.Text = "Extracting program '" & strProgramID & "' from the spreadsheet..."
Application.DoEvents()
arrProgramsInTheSpreadSheet.Add(strProgramID)
arrProgramsPrefixes.Add(strMachinePrefix)
End If
If arrProgramsInTheSpreadSheet.Count = 0 Then
MessageBox.Show(Me, "Could not find programs in the spreadsheet in the column '" & cboxExcelCIMCODBFieldProgram.Text & "', tab '" & cboxExcelTabName.SelectedItem.ToString & "' of the selected spreadsheet!" _
& vbNewLine & vbNewLine & "Please check if the column name selected for program extraction is correct in the spreadsheet and try again.", "Could not find programs in the selected spreadsheet!", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
Exit Sub
End If
Else
ReaderExcelProgramsColumn.Close()
MessageBox.Show(Me, "Could not find programs in the spreadsheet in the column '" & cboxExcelCIMCODBFieldProgram.Text & "', tab '" & cboxExcelTabName.SelectedItem.ToString & "' of the selected spreadsheet!" _
& vbNewLine & vbNewLine & "Please check if the column name selected for program extraction is correct in the spreadsheet and try again.", "Could not find programs in the selected spreadsheet!", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
Exit Sub
End If
strLastProgramID = strProgramID
Application.DoEvents()
Loop
ReaderExcelProgramsColumn.Close()
sqlSelectColumnsExcelPrograms.Dispose()
'Close connection to release memory
ReaderExcelProgramsColumn.Close()
sqlSelectColumnsExcelPrograms.Dispose()
sqlExcelConnection.Dispose()
'Open a new connection
sqlExcelConnection = New OleDbConnection(strConnectionStringExcel)
sqlExcelConnection.Open()
lblStatus.Text = "Starting data extraction... Please wait..."
Application.DoEvents()
'*** Sort the array ***
arrProgramsInTheSpreadSheet.Sort()
'*** Capture Program Extensions ***
For i As Integer = 0 To arrProgramsInTheSpreadSheet.Count - 1
strProgramsQuery = "SELECT TOP 1 [" & strProgramFileExtensionNoPunctuation & "] FROM [" & cboxExcelTabName.Text & "$] WHERE [" & cboxExcelCIMCODBFieldProgram.Text & "] = '" & arrProgramsInTheSpreadSheet.Item(i) & "'"
sqlSelectColumnsExcelPrograms = New OleDbCommand(strProgramsQuery, sqlExcelConnection)
ReaderExcelProgramsColumn = sqlSelectColumnsExcelPrograms.ExecuteReader
Do While ReaderExcelProgramsColumn.Read()
'*****************************************************************************
'** The exception 0x80004005 - Cannot open any more tables occurs somewhere **
'** here, even after I closed the connection between the loops. **
'*****************************************************************************
If ReaderExcelProgramsColumn.HasRows Then
strLastProgramID = arrProgramsInTheSpreadSheet.Item(i)
lblStatus.Text = "Extracting the extension of the program '" & arrProgramsInTheSpreadSheet.Item(i) & "' from the spreadsheet..."
Application.DoEvents()
strProgramFileExtensionFromExcel = Trim(UCase(ReaderExcelProgramsColumn.GetValue(0).ToString))
tupleProgramsAndExtensions.Add((arrProgramsInTheSpreadSheet.Item(i), strProgramFileExtensionFromExcel))
Else
ReaderExcelProgramsColumn.Close()
MessageBox.Show(Me, "HeaderPuncher could not find programs in the spreadsheet in the column '" & cboxExcelCIMCODBFieldProgram.Text & "', tab '" & cboxExcelTabName.SelectedItem.ToString & "' of the selected spreadsheet!" _
& vbNewLine & vbNewLine & "Please check if the column name selected for program extraction is correct in the spreadsheet and try again.", "Could not find programs in the selected spreadsheet!", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
Exit Sub
End If
Loop
Next
ReaderExcelProgramsColumn.Close()
sqlSelectColumnsExcelPrograms.Dispose()
sqlExcelConnection.Dispose()
Thanks!
The answer is what some people mentioned in the comments: The usage of Using / End Using instead of the archaic approach I was using.
Many thanks, everyone!
Related
I'm trying to save data using local database (SQLServerCe) with below code
Private Sub save_setup()
Dim msg As String
Try
If setupupdate = True Then
sql = "UPDATE connection_setup SET datasource_name = '" & t_hostname.Text & "'" & _
", database_name = '" & t_dbname.Text & "', username = '" & t_uid.Text & "'" & _
", password = '" & t_passwd.Text & "'"
msg = "Updated"
Else
sql = "INSERT INTO connection_setup(datasource_name, database_name, username, password)" & _
" VALUES('" & t_hostname.Text & "', '" & t_dbname.Text & "','" & t_uid.Text & "'" & _
" , '" & t_passwd.Text & "') "
msg = "Inserted"
End If
If conCe.State = ConnectionState.Closed Then
conCe.Open()
End If
comCe = New SqlCeCommand(sql, conCe)
comCe.ExecuteNonQuery()
comCe.Dispose()
conCe.Close()
MsgBox(msg, MsgBoxStyle.Information, "Connection Setup")
Catch
MsgBox(Err.Description, MsgBoxStyle.Information, "Connection Setup")
End Try
End Sub
When i push button save, which is run code above, no issue on the process but the data is not saved.
I'm using Visual Studio 2010 with .NET Framework 4.
Any idea what the cause and its solution?
FYI:
If I ran insert/update data by SQL query, the data can be saved.
Your data is saved in a copy of the database in the bin/debug folder. Simplest fix is to specify a full path in the connection string during development.
first, I would like to say that thank all of the programmers, people that make this website so efficient! I'm proud to say that 80% of my programming knowledge on VB I gained was because of all of the samples and answers in this webpage. Anyway, so I'm developing a Quality Control application for my company and there's a datagridview in one of my forms. The user can make changes to it and after that he/she has to save the datagrid back to the MS Access database. I tried everything and I can't save the date field into the database. I checked for field formatting and the database table is formatted to "Date/time"
here is what i have:
Dim sql As String
Try
For i As Integer = 0 To dataAddemdumView.RowCount - 1
sql = "UPDATE MasterRecordsT SET Fecha = '" & dataAddemdumView.Rows(i).Cells("Fecha").Value & "', Pass = " & dataAddemdumView.Rows(i).Cells("Pass").Value & ", Fail =
" & dataAddemdumView.Rows(i).Cells("Fail").Value & ", Employee = " & dataAddemdumView.Rows(i).Cells("Employee").Value & ", Gig = " & dataAddemdumView.Rows(i).Cells("Gig").Value & ", GigNotes =
'" & dataAddemdumView.Rows(i).Cells("GigNotes").Value & "', Department = '" & dataAddemdumView.Rows(i).Cells("Department").Value & "' WHERE ID = " & dataAddemdumView.Rows(i).Cells("ID").Value & ""
cmd = New OleDbCommand(sql, con)
con.Open()
da.UpdateCommand = con.CreateCommand()
da.UpdateCommand.CommandText = sql
da.UpdateCommand.ExecuteNonQuery()
con.Close()
Next
Catch ex As Exception
con.Close()
'MessageBox.Show("OPEX Quality encountered a problem, Try to reopen the application to solve issues", "Error 0002", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
thank you so much for your help guys!
so this would be the final code and it works
Dim sql As String
Try
For i As Integer = 0 To dataAddemdumView.RowCount - 1
If Not dataAddemdumView.Rows(i).Cells("Fecha").Value Is DBNull.Value Then
sql = "UPDATE MasterRecordsT SET Fecha = '" & dataAddemdumView.Item("Fecha", i).Value & "', Pass = " & dataAddemdumView.Rows(i).Cells("Pass").Value & ", Fail =
" & dataAddemdumView.Rows(i).Cells("Fail").Value & ", Employee = " & dataAddemdumView.Rows(i).Cells("Employee").Value & ", Gig = " & dataAddemdumView.Rows(i).Cells("Gig").Value & ", GigNotes =
'" & dataAddemdumView.Rows(i).Cells("GigNotes").Value & "', Department = '" & dataAddemdumView.Rows(i).Cells("Department").Value & "' WHERE ID = " & dataAddemdumView.Rows(i).Cells("ID").Value & ""
cmd = New OleDbCommand(sql, con)
con.Open()
da.UpdateCommand = con.CreateCommand()
da.UpdateCommand.CommandText = sql
da.UpdateCommand.ExecuteNonQuery()
con.Close()
End If
Next
Catch ex As Exception
con.Close()
MsgBox(ex.Message)
'MessageBox.Show("OPEX Quality encountered a problem, Try to reopen the application to solve issues", "Error 0002", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
I have a macro that pulls from an Access DB and writes the recordset to the spreadsheet based upon dates that are entered into a userform. However, if I enter in "3/2/2105" and "3/5/2015" it returns all the records from 3/2-3/5 and then 3/20-3/31. I cannot think of any reason why it would do this. If anybody could point me in the right direction/make suggestions it would be greatly appreciated.
Sub pullfrommsaccess()
queryform.Show
Dim conn As Object
Dim rs As Object
Dim AccessFile As String
Dim SQL As String
Dim startdate As String
Dim enddate As String
Dim i As Integer
Sheet2.Cells.Delete
Application.ScreenUpdating = False
AccessFile = ThisWorkbook.Path & "\" & "mdidatabase.accdb"
On Error Resume Next
Set conn = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
On Error GoTo 0
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
If tblname = "Attainments" Then
If shift1 = "1" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Shift='1' and Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
If shift2 = "2" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Shift='2' and Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
If shift1 = "1" And shift2 = "2" Then
SQL = "SELECT [Line],[Area],[Shift],[Attainment Percentage],[Date] FROM " & tblname & " WHERE Date Between " & "'" & pastdate & "' " & "and" & " '" & currentdate & "'"
End If
End If
If tblname = "MDItable" Then
If shift1misses = "1" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Shift='1' and Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
If shift2misses = "2" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Shift='2' and Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
If shift1misses = "1" And shift2misses = "2" Then
SQL = "SELECT [Date],[Area],[Shift],[Line],[Quantity],[Issue] FROM " & tblname & " WHERE Date Between " & "'" & pastdatemisses & "' " & "and" & " '" & currentdatemisses & "'"
End If
End If
On Error Resume Next
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set rs = Nothing
Set conn = Nothing
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open SQL, conn
If rs.EOF And rs.BOF Then
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For i = 0 To rs.Fields.Count - 1
Sheet2.Cells(1, i + 1) = rs.Fields(i).Name
Next i
'Copy From RecordSet to Excel and Reset
Sheet2.Range("A2").CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "The records from " & pastdate & " and " & currentdate & " were successfully retrieved from the '" & tblname & "' table!", vbInformation, "Done"
End If
Call TrimALL
End Sub
You have a field named Date, try renaming that and reworking the code as in first instance that's a reserved word and is a bad idea for starters!
When working with dates, see Allen Browne's comments on the matter here for consistency;
http://allenbrowne.com/ser-36.html
You have your dates declared as string, but in your SQL query you're surrounding them with a ' not a #. It should read;
Date Between " & "#" & pastdate & "# " & "and" & " #" & currentdate & "#"
All of the above should sort you out, if not comment and I'll take a much closer look for you!
I have a large csv file with lots of data that I need to be able to analysis (~6M rows). I want to connect to the file and run SQL command against it to return only the data I'm interested in analysing. The VBA I'm writing is in Excel 2010.
Everything works fine when the number of rows in the csv file is < 4432669. When the csv file has more rows than this, the command seem to terminate at that point in the file and just returns what ever it has found up to that point. No Error is thrown (CN.Errors), I first though it might be that the command timedout but when I increase this it made no difference. I also checked with different csv files just incase that row contained corrupted data, but no luck. Recordset maxrecords is set to 0 (No limit).
I've tried using Microsoft.Jet.OLEDB.4.0; and driver={Microsoft Text Driver (*.txt; *.csv)}; in the connectionstring, both behave the same as described above.
Here is test code I'm using,
Dim CN As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim Err As ADODB.Error
providerstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\cygwin\home\MarkM\csvimport\filtertest4\;" & _
"Extended Properties=" & Chr(34) & "text;HDR=Yes;FMT=Delimited" & Chr(34) & ";"
CN.ConnectionString = providerstr
CN.Mode = adModeRead
CN.CommandTimeout = 900
CN.Open
RS.Open "SELECT exCode FROM 5M_MBP1R04.csv", CN, adOpenStatic, adLockReadOnly
RS.MoveLast
MsgBox "Number of rows = " & RS.RecordCount
For Each Err In CN.Errors
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr & _
" (SQL State: " & Err.SqlState & ")" & vbCr & _
" (NativeError: " & Err.NativeError & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & " No Help file available"
Else
strError = strError & _
" (HelpFile: " & Err.HelpFile & ")" & vbCr & _
" (HelpContext: " & Err.HelpContext & ")" & _
vbCr & vbCr
End If
Debug.Print strError
Next
Really appreciate any help as I'm completely stuck now.
BR's Mark.
Perhaps you are exceeding a memory constraint due to the CursorType. Try changing it to adOpenForwardOnly
Here is the MSDN page describing Cursor Types.
https://msdn.microsoft.com/en-us/library/windows/desktop/ms681771(v=vs.85).aspx
I'm trying to connect to a SQL server(localhost) and extract the following:
SELECT INVOICENO, SUPPLIERID, AMOUNT, DOCID
FROM ES_TRANS_HEADER
WHERE READYTOINVOICE = 1
I then need to get this information into a .txt file, seperated by commas
This is what I got so far:
function accounting()
Dim myStream, connection, myCommand, recValue
Set myStream = CreateObject("ADODB.Stream")
Set connection = CreateObject("ADODB.Connection")
Set myCommand = CreateObject("ADODB.Command")
connection.Open "Provider=SQLNCLI10;" & _
"Data Source=localhost;" & _
"Integrated Security=SSPI;" & _
"Initial Catalog=SQLDatabase;" & _
"User ID=;Password="
myCommand.ActiveConnection=connection
myCommand.CommandText="SELECT INVOICENO,SUPPLIERID, AMOUNT, DOCID FROM ES_TRANS_HEADER WHERE READYTOINVOICE = 1"
SET recValue = myCommand.Execute()
If Not recValue.EOF then
MsgBox "INVOICENO = " & recValue(0) & vbcrlf & "SUPPLIERID=" & recValue(1) _
& "AMOUNT=" & recValue(2) & "DOCID=" & recValue(3)
End If
While Not recValue.EOF
INVOICENO = recValue(0)
SUPPLIERID = recValue(1)
AMOUNT = recValue(2)
DOCCID = recValue(3)
recValue.MoveNext
Wend
end function
Am I on the right track here, and if so what should I try to do next?
Thanks in advance
MsgBox didn't have any parentheses missing. Remove them (and read Eric Lippert's most awesome blog post on parentheses in VBScript). What's missing in that line is a line continuation character (_) at the end of the line. In VBScript you cannot wrap lines without that. Change this:
MsgBox ("INVOICENO = " & recValue(0) & vbcrlf & "SUPPLIERID=" & recValue(1)
& "AMOUNT=" & recValue(2) & "DOCID=" & recValue(3))
into this:
MsgBox "INVOICENO = " & recValue(0) & vbcrlf & "SUPPLIERID=" & recValue(1) _
& "AMOUNT=" & recValue(2) & "DOCID=" & recValue(3)
or put the whole statement in a single line:
MsgBox "INVOICENO = " & recValue(0) & vbcrlf & "SUPPLIERID=" & recValue(1) & "AMOUNT=" & recValue(2) & "DOCID=" & recValue(3)
As for the database connection, your connection string seems odd. According to the information provided here that connection string is for connections to a mirrored database. Try this instead:
db = "..." 'specify database name here
connection.Open "Provider=SQLNCLI10;" _
& "Server=localhost;" _
& "Database=" & db & ";" _
& "Trusted_Connection=yes;"
If that doesn't help: check the value of the connection's State property:
WScript.Echo connection.State
Also, update your question with any error you're getting (error number, error message and line number).