Option Compare Database
'Khai bao cac bien can dung
Dim Connection As Object
Dim Command As ADODB.Command
Dim RecordSet1 As ADODB.Recordset
Dim RecordSet2 As ADODB.Recordset
Dim iNgay As Long, iNgayDi As Long, iNgayVe As Long
Dim fDate As Date, eDate As Date, i As Long, j As Long, SL As Long
Dim strSQL As String, MyConString As String, fName As String
Dim Arr(), soRec As Long, soField As Long
Sub KetNoi()
Set Connection = New ADODB.Connection
Connection.Open MyConString
'Tao command làm viec voi database
Set Command = New ADODB.Command
Command.ActiveConnection = Connection
Set RecordSet1 = New ADODB.Recordset: Set RecordSet2 = New ADODB.Recordset
End Sub
Sub BoKetNoi()
Connection.Close: Set RecordSet1 = Nothing: Set RecordSet2 = Nothing
Set Connection = Nothing: Set Command = Nothing
End Sub
Sub ganStr()
fName = "E:\Tam\OverAc\OverTwo"
MyConString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source =" & fName & ".mdb"
End Sub
Private Sub TaoKQ()
ganStr
KetNoi
'Tao recordset chua các data cua table Data
RecordSet1.Open "Data", Connection, adOpenStatic, adLockReadOnly, adCmdTable
With RecordSet1
soRec = .RecordCount
soField = .Fields.Count
End With
ReDim Arr(1 To soRec, 1 To soField)
fDate = 0
With RecordSet1
While Not .EOF
For i = 1 To soRec
Arr(i, 1) = .Fields("NgayDi").Value
Arr(i, 2) = .Fields("NgayVe").Value
If fDate = 0 Or CLng(fDate) > CLng(Arr(i, 1)) Then fDate = Arr(i, 1)
If eDate < Arr(i, 2) Then eDate = Arr(i, 2)
.MoveNext
Next i
Wend
End With
TaoMDB
'Mo Recordset2
RecordSet2.Open "KetQua", Connection, adOpenKeyset, adLockOptimistic, adCmdTable
'Tao tung record cua table KetQua
For i = CLng(fDate) To CLng(eDate)
iNgay = i
SL = 0
For j = 1 To UBound(Arr)
If iNgay >= Arr(j, 1) Then
If iNgay <= Arr(j, 2) Then
SL = SL + 1
End If
End If
Next j
With RecordSet2
.AddNew
.Fields("Ngay").Value = CDate(iNgay)
.Fields("SoLuong").Value = SL
.Update
End With
Next i
BoKetNoi
Erase Arr
End Sub
Sub TaoMDB()
'Xoa va tao table Ketqua if true
Command.CommandText = "drop table KetQua"
On Error Resume Next
Command.Execute
'Xay dung SQL tao moi table KetQua gom co 2 field Ngay va soluong
strSQL = "CREATE TABLE KetQua (Ngay date, Soluong integer)"
'Tao table KetQua
Command.CommandText = strSQL
Command.Execute
End Sub
