PDA

View Full Version : VBA slow reading back from database



garydp
05-12-2015, 09:11 AM
I have an Access database that i write to using VBA from an excel spreadsheet.
the spreadsheet has a listview called lstfail loaded with all of the data that is entered into the database.

when data is entered onto the spreadsheet the data is writen to the database without any problem. once the data is saved to the database the listview should update with the latest data from the database. This isnt happening, i am having to close excel and reopen to see the new data. i have even put a time delay in before reading back the data.

this is how im writing to the database



Set cn = New ADODB.Connection
dbPath = Application.ActiveWorkbook.Path & "\Touch Sheet.mdb"
cn.Open "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & dbPath & ";"
Set rs = New ADODB.Recordset
sSQL = "SELECT * From [Failures]"
rs.Open sSQL, cn, adOpenDynamic, adLockOptimistic
rs.AddNew
rs!Date = Format(Now, "dd/mm/yyyy")
rs!Month = Format(Now, "mmmm")
rs!CompTime = ""
rs!Category = cbFCat.Value
rs!Type = cbFType.Value
rs!WO = cbFWO.Value
rs!Serial = txtSerial.Text
rs!PartNo = cbFPartNo.Value
rs!TBCode = Left(cbFTBCode.Value, 2)
rs!TBCodeDesc = Replace(cbFTBCode.Value, Left(cbFTBCode.Value, 4), "")
rs!Lost = "1"
rs!Reason = txtReason.Text
rs!Operator = cbFOperator.Value
rs!process = cbFProcess.Value
rs.Update
rs.Close


this is how loading the listview with the data after writing to the databse



Set cn = New ADODB.Connection
dbPath = Application.ActiveWorkbook.Path & "\Touch Sheet.mdb"
cn.Open "Provider=Microsoft.JET.OLEDB.4.0;Data Source=" & dbPath & ";"
Set rs = New ADODB.Recordset
sSQL = "SELECT * From [Failures] ORDER BY [WO]"
rs.Open sSQL, cn, adOpenDynamic, adLockUnspecified
i = 1
Do Until rs.EOF
With frmTouchSheet.lstFail
.ListItems.Add , , ""
.ListItems.Item(i).ListSubItems.Add = rs!Date
.ListItems.Item(i).ListSubItems.Add = rs!Month
.ListItems.Item(i).ListSubItems.Add = rs!CompTime
.ListItems.Item(i).ListSubItems.Add = rs!Category
.ListItems.Item(i).ListSubItems.Add = rs!Type
.ListItems.Item(i).ListSubItems.Add = rs!WO
.ListItems.Item(i).ListSubItems.Add = rs!Serial
.ListItems.Item(i).ListSubItems.Add = rs!PartNo
.ListItems.Item(i).ListSubItems.Add = rs!TBCode
.ListItems.Item(i).ListSubItems.Add = rs!TBCodeDesc
.ListItems.Item(i).ListSubItems.Add = rs!Lost
.ListItems.Item(i).ListSubItems.Add = rs!Reason
.ListItems.Item(i).ListSubItems.Add = rs!Operator
.ForeColor = vbBlack
.SelectedItem.Selected = False
End With
i = i + 1
rs.MoveNext
Loop


when the first set of data is entered it is loaded into the listview straight away, form the second set onwards it doesnt load or it loads the first set again.

Kenneth Hobs
05-12-2015, 02:23 PM
Be sure to set your connection and record set to nothing. See the end of this example:

'http://www.microsoft.com/downloads/details.aspx?FamilyID=6c050fe3-c795-4b7d-b037-185d0506396c&DisplayLang=en

Option Explicit
'Connection Strings, http://www.connectionstrings.com/


'http://msdn.microsoft.com/en-us/library/ms808325.aspx


Sub ADO()
' Set Reference in Tools to: Microsoft ActiveX Data Objects 2.x Library
Dim DBFullName As String
Dim Cnct As String, Src As String
Dim Connection As ADODB.Connection
Dim RecordSet As ADODB.RecordSet
Dim Col As Integer, Row As Long, s As String

' Database information
DBFullName = ActiveWorkbook.Path & "\NWind2003.mdb"
'Exit?
If Dir(DBFullName) = "" Then Exit Sub


'Clear any existing data from activesheet
Cells.Clear


' Open the connection
Set Connection = New ADODB.Connection
Cnct = "Provider=Microsoft.Jet.OLEDB.4.0; "
Cnct = Cnct & "Data Source=" & DBFullName & ";"
Connection.Open ConnectionString:=Cnct

' Create RecordSet
Set RecordSet = New ADODB.RecordSet
' Record locking
RecordSet.CursorType = adOpenKeyset
RecordSet.LockType = adLockOptimistic

With RecordSet
' Filter
'Src = "SELECT * FROM Products WHERE ProductName = 'Watch' "
'Src = Src & "and CategoryID = 30"
Src = "SELECT Orders.CustomerID, Orders.OrderDate " & _
"FROM Orders " & _
"WHERE (((Orders.OrderDate) " & _
"Between #8/1/1994# and #8/30/1994#))"
RecordSet.Open Source:=Src, ActiveConnection:=Connection


' Write the field names
For Col = 0 To .Fields.Count - 1
Range("A1").Offset(0, Col).Value = RecordSet.Fields(Col).Name
Next Col

' Write the recordset
Range("A1").Offset(1, 0).CopyFromRecordset RecordSet
Dim a As Variant
.MoveFirst
a = RecordSet.GetRows
MsgBox LBound(a), , UBound(a)
MsgBox a(0), , a(1)


If .RecordCount < 1 Then GoTo endnow
.MoveFirst
For Row = 0 To (.RecordCount - 1)
'Debug.Print CStr(.Fields(Row).Value)
.MoveNext
Next Row
End With
endnow:
Set RecordSet = Nothing
Connection.Close
Set Connection = Nothing
End Sub

Aflatoon
05-13-2015, 02:33 AM
You don't appear to be clearing the Listview.Listitems anywhere, so you are adding the new data after the previous data set.

jonh
05-13-2015, 02:39 AM
Close the connection. Maybe something is holding it open.

Also, you probably don't need dynamic cursors.


Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Private Sub Command0_Click()

Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset

cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\test.accdb;"

cn.Open

rs.Open "SELECT * From table1", cn, adOpenStatic, adLockOptimistic

rs.AddNew
rs!a = Day(Date)
rs!b = Month(Date)
rs!c = Year(Date)
rs.Update
rs.Close
cn.Close

rsout
End Sub

Sub rsout()
cn.Open

rs.Open "select * from table1", cn, adOpenForwardOnly, adLockReadOnly

Do Until rs.EOF

'print out
Debug.Print rs(0).Value, rs(1).Value, rs(2).Value, rs(3).Value

rs.MoveNext
Loop
rs.Close
cn.Close
End Sub