I get this error :Invalid attempt when no data is present.It says that line 39 and 198 are the causes of this error
LINE 39
Sub loadstudent()
lvstudent.Items.Clear()
While RD.Read
With lvstudent.Items.Add(RD(1), 0)
.SubItems.Add(RD(5)) '48
.SubItems.Add(RD(0))
End With
End While
End Sub
LINE 198:
sSql = "Select * from tblstudentprof where status='ACTIVE' "
execSQL(sSql, False)
loadstudent()
I also used looping to count the selected items in a listview and move it to tblstudentprof which is connected to line 148 and line 39.
Private Sub btnmove_Click(sender As Object, e As EventArgs) Handles btnmove.Click
Dim ctr, count, minus As Integer
ctr = lvstudent.Items.Count - 1
While ctr >= 0
If lvstudent.Items(ctr).Checked = True Then
sSql1 = "Update tblstudentprof set secid='" & txtsecid.Text & "',yrlevelid='" & txtyrlevelid.Text & _
"',remarks='ENLISTED' where studid ='" & lvstudent.Items(ctr).SubItems(2).Text & "'"
execSQL1(sSql1, True)
ctr -= 1
End If
End While
count = lvstudent.Items.Count
minus = count - ctr1
If minus > 0 Then
MsgBox("There is/are " & minus & "updated students sections.")
Else
MsgBox("Successfully updated students sections.")
End If
Related
I am using VBA in Access to modify a excel sheet using Macro 1 and input it in a table using Macro 2. When I run both of these consecutively, my system gets stuck in a loop, but works fine if I restart the Microsoft access application after running one Macro and run Macro 2. Also at times, the excel file on which I am running my code gets a pop-up box to enable read/write access.. Can someone help me with it?
Macro1
Function Clean()
Dim CurrFilePath, PathName, Week As String
Dim Filename
Dim OpenExcel As Object
Set OpenExcel = CreateObject("Excel.Application")
OpenExcel.Visible = False
Dim OpenWorkbook, WS As Object
Dim i, j As Integer
Dim Count_WS As Integer
OpenExcel.Quit
CurrFilePath = Application.CurrentProject.path
StartTime = Timer
Week = InputBox("Enter the week for the data import e.g. 34")
PathName = CurrFilePath & "\Direct Deliveries\Week " & Week & "\"
Example = CurrFilePath & "\Direct Deliveries\Week " & Week
Confirm:
Confirm_Folder = MsgBox("Does the Direct Deliveries info exist in " & PathName & " path", vbYesNo)
If Confirm_Folder = vbNo Then
path = InputBox("Locate Direct Deliveries .xlsx on your System and Copy the Dir path here e.g." & Example)
PathName = path & "\"
GoTo Confirm
End If
Filename = Dir(PathName & "*.xlsx")
Do While Len(Filename) > 0
Set OpenExcel = CreateObject("Excel.Application")
OpenExcel.Visible = False
OpenExcel.EnableEvents = False
OpenExcel.ScreenUpdating = False
'Variables to track first cell
i = 0
j = 0
PathFile = PathName & Filename
Set OpenWorkbook = OpenExcel.Workbooks.Open(PathFile)
For Each WS In OpenWorkbook.Worksheets
'If condition to check correct worksheets
On Error Resume Next
If Range("A1").Value = "Carrier SCAC" And Range("D1").Value = "Trip ID" Then
'Loop to fill blank TripIDs
For Each Cell In WS.UsedRange.Columns(4).Cells
' For blank cells, set them to equal the cell above
If WS.Cells(Cell.Row, 1) <> "ABCD" And Not IsEmpty(WS.Cells(Cell.Row, 9)) Then
If i <> 0 Then
If (Len(Cell.Text) = 0) And PreviousCell <> "Trip ID" And Cell.Row Then
Cell.Value = PreviousCell
End If
End If
PreviousCell = Cell
i = i + 1
End If
Next Cell
'Loop to fill blank SCAC Codes
For Each CarrierCell In WS.UsedRange.Columns(1).Cells
' For blank cells, set them to equal the cell above
If j <> 0 Then
If (Len(CarrierCell.Text) = 0) And PreviousCell <> "Carrier SCAC" And PreviousCell <> "ABCD" And Not IsEmpty(WS.Cells(CarrierCell.Row, 4)) Then
CarrierCell.Value = PreviousCell
End If
End If
PreviousCell = CarrierCell
j = j + 1
Next CarrierCell
End If
Count_WS = Count_WS + 1
Next WS
Filename = Dir()
OpenWorkbook.Close SaveChanges:=True
Set OpenWorkbook = Nothing
OpenExcel.Quit
Set OpenExcel = Nothing
Loop
'Display the end status
TotalTime = Format((Timer - StartTime) / 86400, "hh:mm:ss")
Application.Echo True
DeleteImportErrTables
End Function
Macro 2
'--------------------------------------------------------
' Author: Akanksha Goel
' The code imports Direct Deliveries erroneous excel templates to Access Database
'------------------------------------------------------------
'
'------------------------------------------------------------
Function ListErrBeforeImports()
Dim OpenExcel As Object
Set OpenExcel = CreateObject("Excel.Application")
OpenExcel.Visible = False
Dim PathFile As String, Filename As String, PathName As String
Dim TableName As String
Dim HasFieldNames As Boolean
Dim OpenWorkbookED As Object
Dim SQL, CurrFilePath As String
Dim SQLcreate, SQLAlter, SQLSet As String
Dim SQL2, SQL3 As String
Dim Count_Templates As Integer
StartTime = Timer
OpenExcel.Quit
'Turn Off the warnings and screen updating
DoCmd.SetWarnings False
Application.Echo False
OpenExcel.EnableEvents = False
OpenExcel.ScreenUpdating = False
CurrFilePath = Application.CurrentProject.path
Week = InputBox("Enter the week for the data import e.g. 34")
PathName = CurrFilePath & "\Direct Deliveries\Week " & Week & "\"
Example = CurrFilePath & "\Direct Deliveries\Week " & Week
Confirm:
Confirm_Folder = MsgBox("Does the Direct Deliveries info exist in " & PathName & " path", vbYesNo)
If Confirm_Folder = vbNo Then
path = InputBox("Locate Direct Deliveries .xlsx on your System and Copy the Dir path here e.g." & Example)
PathName = path & "\"
GoTo Confirm
End If
HasFieldNames = True
TableName = "TempTable"
Filename = Dir(PathName & "*.xlsx")
PathFile = PathName & Filename
'Arguments for function AssignTablesToGroup()
Dim Arg1 As String
Dim Arg2 As Integer
Arg1 = "EmptyDeliveryDates_TripsWeek" & Week
Call DeleteTable(Arg1)
Arg2 = 383
SQLcreate = "Create Table EmptyDeliveryDates_TripsWeek" & Week & " ( TripID Text, ShipToZip Text, ArriveDelivery Text, Carrier Text, SourceWorkbook Text);"
DoCmd.RunSQL SQLcreate
'Assign Error Table to 'Errors in DirectDeliveries Excels' Group
Call AssignToGroup(Arg1, Arg2)
'Arguments for function AssignTablesToGroup()
Dim Arg3 As String
Arg3 = "InvalidZip_TripsWeek" & Week
DeleteTable Arg3
Arg2 = 383
SQLcreate = "Create Table InvalidZip_TripsWeek" & Week & " ( TripID Text, ShipToZip Text, ArriveDelivery Text, Carrier Text, SourceWorkbook Text);"
DoCmd.RunSQL SQLcreate
'Assign Error Table to 'Errors in DirectDeliveries Excels' Group
Call AssignToGroup(Arg3, Arg2)
'Arguments for function AssignTablesToGroup()
Dim Arg4 As String
Arg4 = "InvalidTrip_TripsWeek" & Week
DeleteTable Arg4
Arg2 = 383
SQLcreate = "Create Table InvalidTrip_TripsWeek" & Week & " ( TripID Text, ShipToZip Text, ArriveDelivery Text, Carrier Text, SourceWorkbook Text);"
DoCmd.RunSQL SQLcreate
'Assign Error Table to 'Errors in DirectDeliveries Excels' Group
Call AssignToGroup(Arg4, Arg2)
Do While Len(Filename) > 0
Set OpenExcel = CreateObject("Excel.Application")
OpenExcel.Visible = False
OpenExcel.EnableEvents = False
OpenExcel.ScreenUpdating = False
PathFile = PathName & Filename
Set OpenWorkbookED = OpenExcel.Workbooks.Open(PathFile, ReadOnly)
Set WS_Book = OpenWorkbookED.Worksheets
DeleteTable "TempTable"
'Loop through Worksheets in each template workbook
For Each WS In WS_Book
WorksheetName = WS.Name
x = WS.Range("A1")
If WS.Range("A1") = "Carrier SCAC" Then
'Get the used records in worksheet
GetUsedRange = WS.UsedRange.Address(0, 0)
'Import records from worksheet into Access Database table
DoCmd.TransferSpreadsheet acImport, 10, "TempTable", PathFile, HasFieldNames, WorksheetName & "!" & GetUsedRange
SQLAlter = "ALTER TABLE TempTable ADD COLUMN SourceBook TEXT(100)"
DoCmd.RunSQL SQLAlter
SQLSet = "UPDATE TempTable SET TempTable.SourceBook = '" & Filename & "' where ([Arrive Delivery]) is NULL or len([Arrive Delivery])<2 or len([Trip ID])<8 or len([Ship to Zip])<5;"
DoCmd.RunSQL SQLSet
SQL = "INSERT INTO " & Arg4 & "(TripID, ShipToZip, ArriveDelivery, Carrier, SourceWorkbook) Select Distinct [Trip ID], [Ship to Zip], [Arrive Delivery], [Carrier SCAC], SourceBook FROM TempTable WHERE len([Trip ID])<8 and len([Ship To Zip])>0 and len([Arrive Delivery])>0;"
DoCmd.RunSQL SQL
SQL2 = "INSERT INTO " & Arg3 & "(TripID, ShipToZip, ArriveDelivery, Carrier, SourceWorkbook) Select Distinct [Trip ID], [Ship to Zip], [Arrive Delivery], [Carrier SCAC], SourceBook FROM TempTable WHERE len([Ship To Zip])<5 and len([Arrive Delivery])>0 and len([Trip ID])>0;"
DoCmd.RunSQL SQL2
SQL3 = "INSERT INTO " & Arg1 & "(TripID, ShipToZip, ArriveDelivery, Carrier, SourceWorkbook) Select Distinct [Trip ID], [Ship to Zip], [Arrive Delivery], [Carrier SCAC], SourceBook FROM TempTable WHERE ([Arrive Delivery] is NULL or len([Arrive Delivery])<2) and len([Ship To Zip])>0 and len([Trip ID])>0 ;"
DoCmd.RunSQL SQL3
DoCmd.DeleteObject acTable, "TempTable"
Count_Templates = Count_Templates + 1
End If
Next WS
OpenWorkbookED.Saved = True
OpenWorkbookED.Close
Filename = Dir()
Set OpenWorkbookED = Nothing
OpenExcel.Quit
Set OpenExcel = Nothing
Loop
'Display the end status
TotalTime = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Done! Error tables updated in 'Errors in DirectDeliveries Excels' group in with " & Count_Templates & " Templates " & TotalTime & " minutes", vbInformation
Application.Echo True
'CallFunction Delete Import Tables
DeleteImportErrTables
End Function
Merge the two functions so you only open one instance (your OpenExcel object) of Excel.
I would like to have a check-box that, when ticked, filters the loaded data to only include data where it has been at least one month until the "Expected pair maturation" date. Here is my attempt:
Private Sub LockFilter1Chk_Click()
If Me!LockFilter1Chk = True Then
Me.RecordSource = "SELECT * FROM staff " & _
WHERE DateDiff("m", Me![Expected pair maturation], Now()) > 1 "
End If
If Me!LockFilter1Chk = Not True Then
Me.RecordSource = "SELECT * FROM Staff "
End If
End Sub
It might be simple to set the Filter:
Private Sub LockFilter1Chk_Click()
If Me!LockFilter1Chk = True Then
Me.Filter = "[Expected pair maturation] < DateAdd("m", -1, Date())"
Me.FilterOn = True
Else
Me.FilterOn = False
End If
End Sub
After a string and line concatenation & _ you need a new double quote to start the new string.
If you have " inside a string, you must mask it as "".
In a SQL SELECT recordsource, don't refer to Me!. You are comparing the value from the table, so only use the field name.
Some indentation helps a lot with readability.
This should be closer (not sure if it already does what you want).
Private Sub LockFilter1Chk_Click()
If Me!LockFilter1Chk = True Then
Me.RecordSource = "SELECT * FROM staff " & _
"WHERE DateDiff(""m"", [Expected pair maturation], Now()) > 1 "
Else
Me.RecordSource = "SELECT * FROM Staff "
End If
End Sub
You did not mention what was your problem.
You can do it the way you did, but I would use an if then else construct:
Private Sub LockFilter1Chk_Click()
If Me!LockFilter1Chk = True Then
Me.RecordSource = "SELECT * FROM staff " & _
"WHERE [Expected pair maturation] < DateAdd('m', -1, Date())"
else
Me.RecordSource = "Staff"
End If
End Sub
Alternatively you could leave the record Source unchanged and use a filter:
If Me!LockFilter1Chk = True Then
docmd.applyfilter , "[Expected pair maturation] < DateAdd('m', -1, Date())"
else
me.filterOn = false
end if
Note: If you have quotes within quotes, you can also use single quotes inside:
"DateDiff('m', Me![Expected pair maturation], Now()) > 1 "
Based on this tutorial page, how does Microsoft Access know that a field created for an index fields collection associates to an equivalent field in the TableDef fields collection?
Even in this Microsoft Support page, fields are created for the index and then appended to the index's fields collection:
...
'Copy Indexes
For I1 = 0 To SourceTableDef.Indexes.Count - 1
Set SI = SourceTableDef.Indexes(I1)
If Not SI.Foreign Then ' Foreign indexes are added by relationships
Set I = T.CreateIndex()
' Copy Jet Properties
On Error Resume Next
For P1 = 0 To I.Properties.Count - 1
I.Properties(P1).Value = SI.Properties(P1).Value
Next P1
On Error GoTo 0
' Copy Fields
For f1 = 0 To SI.Fields.Count - 1
Set F = T.CreateField(SI.Fields(f1).Name, T.Fields(SI.Fields(f1).Name).Type)
I.Fields.Append F
Next f1
T.Indexes.Append I
End If
Next I1
...
Can't I simply add the existing field from the TableDef's fields collection? This makes little sense and seems to have very little in the way of cohesion.
Update
I actually tested the code here which is basically what I want to do ... but it fails with an undefined object error on this line:
Set F = T.CreateField(SI.Fields(f1).Name, T.Fields(SI.Fields(f1).Name).Type)
...and we have all sorts of fun when we change this.
(23/05/2016) Further, this script appears to be wrong - the second argument shouldn't actually be there, it's unnecessary. Omitting it causes further errors! Ha! Where's my tail? I'm getting the feeling that I should be chasing it.
A solution to my problem
I decided to follow HansUp's lead and use DDL - far easier than attempting to trawl through the problems associated to the manipulation of objects (though there was some level of this in the final code design)...
Option Compare Database
Public Const cFname As String = "drm\drmData2016.accdb"
Public Const cPropNotFound As Integer = 3270
Public Const cNotSupported As Integer = 3251
Public Const cInvalidOp As Integer = 3219
Public Sub GenerateTables()
OpenLog
'Initalise...
Dim db As Database
Dim tdb As Database
Dim ts As TableDef, tt As TableDef
Dim p As Property
Dim f As Field, ft As Field
Dim i As Index
Dim s As String, t As String
Dim x As Boolean
Set db = CurrentDb
If Dir$(cFname) <> "" Then Kill cFname
Set tdb = Application.DBEngine.CreateDatabase(cFname, dbLangGeneral, dbVersion140)
WriteLog "Created database " & cFname & "."
'Create the tables...
WriteLog "Creating TableDefs...", 1
For Each ts In db.TableDefs
If Not StartsWith(ts.Name, "msys", "~", "$", "Name AutoCorrect") And Not EndsWith(ts.Name, "_xrep") Then
s = "SELECT "
For Each f In ts.Fields
If Not StartsWith(f.Name, "s_", "S_") Then s = s & "[" & f.Name & "], "
Next f
s = Left$(s, Len(s) - 2) & " INTO [" & ts.Name & "] IN """ & cFname & """ FROM [" & ts.Name & "];"
On Error Resume Next
db.Execute s
If Err.Number = 0 Then
WriteLog "Created [" & ts.Name & "] using " & s, 2
Else
WriteLog "Failed to create [" & ts.Name & "].", 2
WriteLog "Error " & Err.Number & ": " & Err.Description, 3
WriteLog "SQL: " & s, 3
Err.Clear
End If
tdb.TableDefs.Refresh
On Error GoTo 0
End If
Next ts
'Copy the properties...
WriteLog "Tables...", 1
For Each ts In db.TableDefs
If Not StartsWith(ts.Name, "msys", "~", "$", "Name Autocorrect") And Not EndsWith(ts.Name, "_xrep") Then
Set tt = tdb.TableDefs(ts.Name)
WriteLog ts.Name, 2
WriteLog "Table Properties...", 3
'Table properties...
For Each p In ts.Properties
On Error Resume Next
tt.Properties(p.Name) = p.value
If Err.Number = 0 Then
WriteLog p.Name & " = " & p.value, 3
Else
WriteLog "Error setting " & p.Name, 3
WriteLog Err.Number & ": " & Err.Description, 4
Err.Clear
End If
On Error GoTo 0
Next p
'Field properties...
WriteLog "Fields...", 3
For Each f In ts.Fields
If Not StartsWith(f.Name, "s_") Then
Set ft = tt.Fields(f.Name)
WriteLog f.Name, 3
WriteLog "Properties...", 3
For Each p In f.Properties
On Error Resume Next
ft.Properties(p.Name).value = p.value
Select Case Err.Number
Case 0
'Normal...
WriteLog p.Name & " = " & p.value, 4
Case cPropNotFound
'Create the property...
Dim np As Property
Set np = ft.CreateProperty(p.Name, p.Type, p.value)
ft.Properties.Append np
ft.Properties.Refresh
WriteLog "Created property " & p.Name & ", value of " & p.value, 4
Case cNotSupported, cInvalidOp
'We're not worried about these values - simply skip over them...
Case Else
WriteLog "Failed to create or change property " & p.Name & ".", 4
WriteLog "Error " & Err.Number & ": " & Err.Description, 5
Err.Clear
End Select
On Error GoTo 0
Next p
End If
Next f
'Create the indexes...
WriteLog "Table indexes...", 2
For Each i In ts.Indexes
x = False
s = "CREATE "
If i.Unique Then s = s & "UNIQUE "
s = s & "INDEX [" & i.Name & "] ON [" & ts.Name & "] ("
For Each f In i.Fields
s = s & "[" & f.Name & "], "
'Just make sure we're not dealing with replication fields...
x = StartsWith(f.Name, "s_")
Next f
'We only want
If Not x Then
WriteLog i.Name, 3
s = Left$(s, Len(s) - 2) & ") "
If i.Primary Or i.IgnoreNulls Or i.Required Then
s = s & "WITH "
If i.Primary Then s = s & "PRIMARY "
If i.IgnoreNulls Then s = s & "IGNORE NULL "
If i.Required Then s = s & "DISALLOW NULL "
End If
s = s & ";"
On Error Resume Next
tdb.Execute s
Select Case Err.Number
'Note: used select case just in case I need to add extra error numbers...
Case 0
'Normal...
WriteLog "Created index [" & i.Name & "] using " & s, 4
Case Else
WriteLog "Failed to create index [" & ts.Name & "].", 4
WriteLog "Error " & Err.Number & ": " & Err.Description, 5
WriteLog "SQL: " & s, 3
Err.Clear
End Select
On Error GoTo 0
End If
Next i
End If
Next ts
'Belt and braces tidy-up...
Set p = Nothing
Set f = Nothing
Set ft = Nothing
Set i = Nothing
Set ts = Nothing
Set tt = Nothing
tdb.Close
Set tdb = Nothing
Set db = Nothing
WriteLog "Closed database."
WriteLog "Finished.", , False
CloseLog
End Sub
how does Microsoft Access know that a field created for an index
fields collection associates to an equivalent field in the TableDef
fields collection?
It checks based on the name. The name of the new index field must exist in the TableDef and that field's datatype must be one which is indexable. If either of those conditions is not satisfied, you will get an error message.
In summary:
An index is (from DAO point of view) basically a data structure with some properties and a collection of field names + their data types.
It is not a collection of pointers to tabledef fields.
To add fields to an index via DAO one needs a field object, which is created by CreateField().
The index object has a .CreateField() method too, which is actually the more common way to do this, I'd say.
From http://allenbrowne.com/func-dao.html#CreateIndexesDAO :
'3. Multi-field index.
Set ind = tdf.CreateIndex("FullName")
With ind
.Fields.Append .CreateField("Surname")
.Fields.Append .CreateField("FirstName")
End With
tdf.Indexes.Append ind
Note that this method doesn't take the Type and Size parameters, only the Name. I will happily admit that all this is a bit confusing (or incoherent, if you want).
I have developed a winform which requires constant contact with a mysql database to make sure all "calls" are fetched and up to date - the problem I have run into is that my listview is only being populated with 1 line per timer click. this timer should activate a while statement that should process all data and in fact should also be clearing the listview to receive updated data. why is my listview only populating 1 item per tick?
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
ListView2.Items.Clear()
con.ConnectionString = "server=localhost;" _
& "user id=username;" _
& "password=password;" _
& "database=DMT"
adptr = New MySqlDataAdapter("SELECT * , s.fid AS sfid, s.name AS sname, s.faddress AS sfaddress, s.fcity AS sfcity, s.fstate AS sfstate, s.fcontnumb AS sfcontnumb, s.fcontname AS sfcontname, s.fcontract AS sfcontract, d.fid AS dfid, d.name AS dname, d.faddress AS dfaddress, d.fcity AS dfcity, d.fstate AS dfstate, d.fcontnumb AS dfcontnumb, d.fcontname AS dfcontname, d.fcontract AS dfcontract FROM calls c LEFT JOIN facilities s ON c.Scene = s.fid LEFT JOIN facilities d ON c.Dest = d.fid WHERE putime < now( ) + INTERVAL 12 HOUR && Rdisp IS NULL ORDER BY putime desc", con)
Try
adptr.Fill(pendrun)
Catch err As Exception
Dim strError As String = "Exception: & err.ToString()"
End Try
If pendrun.Rows.Count > 0 Then
While pop < pendrun.Rows.Count - 1
TempStr(0) = pendrun.Rows(pop)("RID")
Select Case pendrun.Rows(pop)("Utype")
Case 1
TempStr(1) = "BLS Ambulance"
Case 2
TempStr(1) = "ALS Ambulance"
Case 3
TempStr(1) = "SCT Ambulance"
Case 4
TempStr(1) = "Wheelchair Van"
Case 5
TempStr(1) = "Taxi"
End Select
Select Case pendrun.Rows(pop)("Curgency")
Case 1
TempStr(2) = "Scheduled"
Case 2
TempStr(2) = "Non-Scheduled"
Case 3
TempStr(2) = "ASAP"
Case 4
TempStr(2) = "STAT"
End Select
TempStr(3) = pendrun.Rows(pop)("Pname")
TempStr(4) = pendrun.Rows(pop)("Texttime")
TempStr(5) = pendrun.Rows(pop)("sname") & " - " & pendrun.Rows(pop)("sfaddress") & ", " & pendrun.Rows(pop)("sfcity") & ", " & pendrun.Rows(pop)("sfstate")
TempStr(6) = pendrun.Rows(pop)("dname") & " - " & pendrun.Rows(pop)("dfaddress") & ", " & pendrun.Rows(pop)("dfcity") & ", " & pendrun.Rows(pop)("dfstate")
TempNode = New ListViewItem(TempStr)
ListView2.Items.Add(TempNode)
pop += 1
End While
End If
End Sub
I have verified it is in fact linked to the timer directly (1 item per tick) by varying the timer from 1 second to 30 seconds and it does directly change this.
Your code never resets "pop"'s value. That's what's causing trouble, I'm pretty sure. It keeps incrementing 1 value every tick, never able to do all of them because pop is set to one less than the while's max.
Im working with my project inventory system i want to display the filtered dates in my books table in the mysql in my listview1 using 2 DTPicker and make a report for it. Im having an error in my query in the classmodule idk if its only the query and im really confused im a begginer in vb 6.0...please in need your help guys.
Im using 2 tables namely books and supplier.
MY CODE IN THE 'CLASS MODULE':
Sub DisplayList(ListView1 As ListView, DateFrom As Date, DateTo As Date)
Dim lstItem As ListItem, a As Integer
Dim rs As New ADODB.Recordset
Dim sql As String
If rs.State = adStateOpen Then rs.Close
sql = " SELECT supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" From supplier INNER JOIN books" & _
" ON supplier.code=books.code" & _
" WHERE (((books.dataAcquired)>=#" & DateFrom & "#) and ((books.dataAcquired) <=#" & DateTo & "#))" & _
" GROUP BY supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" ORDER BY books.dataAcquired DESC;"
rs.Open sql, cnn
ListView1.ListItems.Clear
Do While Not rs.EOF
a = a + 1
Set lstItem = ListView1.ListItems.Add(, , a, 1, 1)
lstItem.SubItems(1) = rs(0).Value
lstItem.SubItems(2) = rs(1).Value
lstItem.SubItems(3) = rs(2).Value
lstItem.SubItems(4) = rs(3).Value
lstItem.SubItems(5) = rs(4).Value
lstItem.SubItems(6) = rs(5).Value
lstItem.SubItems(7) = rs(6).Value
rs.MoveNext
Loop
End Sub
MY CODE IN MY FORM:
Private Sub Show_Click()
clsData.DisplayList ListView1, DTPicker1.Value, DTPicker2.Value
lblCount.Caption = ListView1.ListItems.Count
End Sub
Private Sub Form_Load()
DTPicker1.Value = Date
DTPicker2.Value = Date
End Sub
Private Sub Form_Activate()
clsData.DisplayList ListView1, DTPicker1.Value, DTPicker2.Value
lblCount.Caption = ListView1.ListItems.Count
End Sub
Change # by '
format date how yyyy-MM-dd or yyyyMMdd
sql = " SELECT supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" From supplier INNER JOIN books" & _
" ON supplier.code=books.code" & _
" WHERE (((books.dataAcquired)>='" & format(DateFrom,"yyyy-MM-dd") & "') and ((books.dataAcquired) <='" & format(DateTo,"yyyy-MM-dd") & "'))" & _
" GROUP BY supplier.category,books.title,books.dataAcquired,books.amount,books.quantity,books.accesionno,books.conditions" & _
" ORDER BY books.dataAcquired DESC;"
change loop while added validations for recordset emptys, some how
if RecordsetIsClosed(rs) then exit sub
While Not RecordSetIsEmpty(rs)
a = a + 1
Set lstItem = ListView1.ListItems.Add(, , a, 1, 1)
lstItem.SubItems(1) = rs(0).Value
lstItem.SubItems(2) = rs(1).Value
lstItem.SubItems(3) = rs(2).Value
lstItem.SubItems(4) = rs(3).Value
lstItem.SubItems(5) = rs(4).Value
lstItem.SubItems(6) = rs(5).Value
lstItem.SubItems(7) = rs(6).Value
rs.MoveNext
wend
Public Function RecordSetIsEmpty(ByRef rs As ADODB.Recordset) As Boolean
' On Local Error GoTo RecordSetIsEmpty_Error
' RecordSetIsEmpty = True
' If rs Is Nothing Then
' RecordSetIsEmpty = True
' Exit Function
' End If
' If RecordsetIsClosed(rs) = True Then
' RecordSetIsEmpty = True
' Exit Function
' End If
RecordSetIsEmpty = (rs.BOF = True And rs.EOF = True)
' RecordSetIsEmpty_Done:
' Exit Function
' RecordSetIsEmpty_Error:
' Resume RecordSetIsEmpty_Done
End Function
Public Function RecordsetIsClosed(ByRef rs As ADODB.Recordset) As Boolean
On Local Error GoTo RecordsetIsClosed_Error
RecordsetIsClosed = True
If rs Is Nothing Then
RecordsetIsClosed = True
End If
If rs.State <> adStateClosed Then
RecordsetIsClosed = False
End If
RecordsetIsClosed_Done:
Exit Function
RecordsetIsClosed_Error:
Resume RecordsetIsClosed_Done
End Function
Dont forget to open the database connection
updated thanks Mark Bertenshaw
RecordSetIsEmpty is use for problems when do movenext.. well i remember
RecordsetIsClosed is use because in some cases and databases managers return not recordset or the recordset is not correct initialized
for example access is necessary use movefist before do movenext or read values