Как сделать базу данных на ADO

Dim ws As Workspace
Dim db As Database
Dim strBookMark As String
Dim Mas() As String
Dim MaxCount As Integer
Dim DelCount As Integer
Dim i As Integer
Dim x As Integer
Public rs As Recordset
 
Private Sub cmdAddNew_Click()
If cmdAddNew.Caption = "Íîâàÿ" Then
LockButtons
rs.AddNew
loadRecord
txttip.SetFocus
Else
SaveRecord
rs.Update
rs.MoveLast
loadRecord
UnLockButtons
End If
End Sub
 
Private Sub cmdDel_Click()
If MsgBox("Óäàëèòü òåêóùóþ çàïèñü?", vbQuestion + vbYesNo, "Óäàëåíèå") = vbYes Then
rs.Delete
cmdMovePrevious_Click
End If
End Sub
 
Private Sub cmdDeletebookmark_Click()
If cboBookmarks.ListIndex = -1 Then
MsgBox "ñíà÷àëà âûáåðåòå óäàëÿåìóþ çàêëàäêó", vbExlamation
Exit Sub
End If
For i = cboBookmarks.ListIndex To UBound(Mas) - 1
Mas(i) = Mas(i + 1)
Next i
MaxCount = MaxCount - 1
ReDim Preserve Mas(MaxCount)
cboBookmarks.RemoveItem cboBookmarks.ListIndex
End Sub
 
Private Sub cmdEdit_Click()
If cmdEdit.Caption = "Ðåäàêòèðîâàòü" Then
LockButtons
rs.Edit
txttip.SetFocus
Else
rs.CancelUpdate
rs.MoveFirst
loadRecord
UnLockButtons
End If
End Sub
 
Private Sub cmdFind_Click()
frmfind.Show
End Sub
 
Private Sub cmdMoveFirst_Click()
rs.MoveFirst
loadRecord
End Sub
 
Private Sub cmdMovelast_Click()
rs.MoveLast
loadRecord
End Sub
 
Private Sub cmdMoveNext_Click()
If rs.EOF = True Then
LockButtons
rs.MoveLast
Beep
MsgBox "Ýòî ïîñëåäíÿÿ çàïèñü!", vbInformation, "Âíèìàíèå!"
Else
rs.MoveNext
If rs.EOF = True Then
rs.MoveLast
MsgBox "Ýòî ïîñëåäíÿÿ çàïèñü", vbInformation, "Âíèìàíèå!"
End If
End If
loadRecord
End Sub
 
Private Sub cmdMovePrevious_Click()
If rs.BOF = True Then
rs.MoveFirst
Beep
MsgBox "Ýòî ïåðâàÿ çàïèñü!", vbInformation, "Âíèìàíèå!"
Else
rs.MovePrevious
If rs.BOF = True Then
rs.MoveFirst
MsgBox "Ýòî ïåðâàÿ çàïèñü", vbInformation, "Âíèìàíèå!"
End If
End If
loadRecord
 
End Sub
 
Private Sub CmdSaveBookmark_Click()
cboBookmarks.AddItem txttip.Text
ReDim Preserve Mas(MaxCount)
MaxCount = UBound(Mas)
Mas(MaxCount) = rs.Bookmark
MsgBox MaxCount
MaxCount = MaxCount + 1
End Sub
 
Private Sub cboBookmarks_Click()
rs.Bookmark = Mas(cboBookmarks.ListIndex)
loadRecord
End Sub
 
Private Sub cmdExportTXT_Click()
Dim Af As Scripting.FileSystemObject
Dim txt As Scripting.TextStream
Dim Counter As Long
Set fs = New Scripting.FileSystemObject
Set txt = fs.OpenTextFile("D:\DataBase\SergeyBD.txt", ForWriting, True)
Do Until rs.EOF
txt.Write rs!tip & vbTab
txt.Write rs!Name & vbTab
txt.Write rs!Scale & vbTab
txt.Write rs!Address & vbTab
txt.Write rs!prise & vbTab
txt.Write rs!datep & vbTab
txt.Write rs!buyname & vbTab
txt.Write rs!garantyear & vbTab
txt.Write rs!Notes & vbCrLf
Counter = Counter + 1
rs.MoveNext
Loop
txt.Close
Set txt = Nothing
Set fs = Nothing
loadRecord
MsgBox "Âûâîä äàííûõ â òåêñòîâûé ôàéë çàêîí÷åí.", vbInformation, "Ýêñïîðò"
End Sub
 
Private Sub cmdExportword_Click()
Dim wordapp As Word.Application
Dim doc As Word.Document
Dim sel As Word.Selection
Set wordapp = New Word.Application
On Error Resume Next
wordapp.Documents.Add
Set doc = wordapp.ActiveDocument
Set sel = wordapp.Selection
doc.Tables.Add sel.Range, 1, 8
Do Until rs.EOF
sel.TypeText rs!tip
sel.MoveRight 12
sel.TypeText rs!Name
sel.MoveRight 12
sel.TypeText rs!Scale
sel.MoveRight 12
sel.TypeText rs!Address
sel.MoveRight 12
sel.TypeText rs!prise
sel.MoveRight 12
sel.TypeText rs!datep
sel.MoveRight 12
sel.TypeText rs!buyname
sel.MoveRight 12
sel.TypeText rs!garantyear
sel.MoveRight 12
rs.MoveNext
Counter = Counter + 1
lblCounter.Caption = "Êîëè÷åñòâî ýêñïîðòèðîâàíûõ çàïèñåé = " & Counter
Loop
loadRecord
wordapp.Visible = True
Set wordapp = Nothing
 
End Sub
 
Private Sub cmdExportExcel_Click()
Dim excelapp As Excel.Application
Dim book As Excel.Workbook
Set excelapp = New Excel.Application
excelapp.Workbooks.Add
Set book = excelapp.ActiveWorkbook
Do Until rs.EOF
Counter = Counter + 1
book.ActiveSheet.Range("a" & Counter).FormulaR1C1 = rs!tip
book.ActiveSheet.Range("b" & Counter).FormulaR1C1 = rs!Name
book.ActiveSheet.Range("c" & Counter).FormulaR1C1 = rs!Scale
book.ActiveSheet.Range("d" & Counter).FormulaR1C1 = rs!Address
book.ActiveSheet.Range("e" & Counter).FormulaR1C1 = rs!prise
book.ActiveSheet.Range("f" & Counter).FormulaR1C1 = rs!datep
book.ActiveSheet.Range("g" & Counter).FormulaR1C1 = rs!buyname
book.ActiveSheet.Range("h" & Counter).FormulaR1C1 = rs!garantyear
book.ActiveSheet.Range("i" & Counter).FormulaR1C1 = rs!Notes
rs.MoveNext
Loop
excelapp.Visible = True
Set excelapp = Nothing
loadRecord
 
End Sub
 
Private Sub Form_Load()
Set ws = DBEngine.CreateWorkspace("MyWS", "admin", "")
Set db = ws.OpenDatabase("D:\DataBase\SergeyBD.mdb")
Set rs = db.OpenRecordset("Sale", dbOpenDynaset)
MaxCount = 0
loadRecord
End Sub
 
Public Sub loadRecord()
txttip.Text = ""
txtName.Text = ""
TxtScale.Text = ""
txtaddress.Text = ""
txtprise.Text = ""
txtdateP.Text = ""
txtBuyName.Text = ""
txtGarantyear.Text = ""
txtNotes.Text = ""
On Error Resume Next
txttip.Text = rs.Fields("Tip")
txtName.Text = rs!Name
TxtScale.Text = rs!Scale
txtaddress.Text = rs!Address
txtprise.Text = rs!prise
txtdateP.Text = rs!datep
txtBuyName.Text = rs!buyname
txtGarantyear.Text = rs!garantyear
txtNotes.Text = rs!Notes
End Sub
 
Private Sub SaveRecord()
rs!tip = txttip.Text
rs!Name = txtName.Text
rs!Scale = TxtScale.Text
rs!Address = txtaddress.Text
rs!prise = txtprise.Text
rs!datep = txtdateP.Text
rs!buyname = txtBuyName.Text
rs!garantyear = txtGarantyear.Text
rs!Notes = txtNotes.Text
 
End Sub
 
 
Private Sub UnLockButtons()
'txtTip.Locked = True
'txtName.Locked = True
'TxtScale.Locked = True
'txtaddress.Locked = True
'txtprise.Locked = True
'txtdateP.Locked = True
'txtBuyName.Locked = True
'txtGarantyear.Locked = True
'txtnotes.Locked = True
'cmdAddNew.Locked = True
'cmdDel.Locked = True
'cmdEdit.Locked = True
'cmdFind.Locked = True
'cmdMoveFirst.Locked = True
'cmdMovePrevious.Locked = True
'cmdMoveNext.Locked = True
'cmdMovelast.Locked = True
cmdAddNew.Caption = "Íîâàÿ"
cmdEdit.Caption = "Ðåäàêòèðîâàòü"
 
 
End Sub
 
Private Sub LockButtons()
'txtTip.Locked = False
'txtName.Locked = False
'TxtScale.Locked = False
'txtaddress.Locked = False
'txtprise.Locked = False
'txtdateP.Locked = False
'txtBuyName.Locked = False
'txtGarantyear.Locked = False
'txtnotes.Locked = False
'cmdAddNew.Locked = False
'cmdDel.Locked = False
'cmdEdit.Locked = False
'cmdFind.Locked = False
'cmdMoveFirst.Locked = False
'cmdMovePrevious.Locked = False
'cmdMoveNext.Locked = False
'cmdMovelast.Locked = False
 
cmdAddNew.Caption = "Ñîõðàíèòü"
cmdEdit.Caption = "Îòìåíà"
 
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
rs.Close
db.Close
ws.Close
Set rs = Nothing
Set db = Nothing
Set ws = Nothing
End Sub

Option Explicit
 
 
Private Sub Chkaddress_Click()
txtaddress.Visible = Chkaddress.Value
End Sub
 
Private Sub chkbuyname_Click()
txtBuyName.Visible = chkbuyname.Value
End Sub
 
Private Sub chkdatep_Click()
txtdateP.Visible = chkdatep.Value
End Sub
 
Private Sub chkGarantyear_Click()
txtGarantyear.Visible = chkGarantyear.Value
End Sub
 
Private Sub Chkname_Click()
txtName.Visible = Chkname.Value
End Sub
 
Private Sub chkprise_Click()
txtprise.Visible = chkprise.Value
End Sub
 
Private Sub Chkscale_Click()
TxtScale.Visible = Chkscale.Value
End Sub
 
Private Sub Chktip_Click()
txttip.Visible = Chktip.Value
End Sub
 
Private Sub cmdfindfirst_Click()
frmsale.rs.FindFirst CreateCriteria
If frmsale.rs.NoMatch = True Then
MsgBox "Çàïèñü " + CreateCriteria + " íå íàéäåíà", vbInformation, "Ðåçóëüòàòû ïîèñêà"
End If
frmsale.loadRecord
End Sub
 
Private Sub cmdfindlast_Click()
frmsale.rs.FindLast CreateCriteria
If frmsale.rs.NoMatch = True Then
MsgBox "Çàïèñü " + CreateCriteria + " íå íàéäåíà", vbInformation, "Ðåçóëüòàòû ïîèñêà"
Else
frmsale.loadRecord
End If
End Sub
 
Private Sub cmdfindnext_Click()
frmsale.rs.FindNext CreateCriteria
If frmsale.rs.NoMatch = True Then
MsgBox "Çàïèñü " + CreateCriteria + " íå íàéäåíà", vbInformation, "Ðåçóëüòàòû ïîèñêà"
Else
frmsale.loadRecord
End If
End Sub
 
Private Sub cmdFindprevious_Click()
frmsale.rs.FindPrevious CreateCriteria
If frmsale.rs.NoMatch = True Then
MsgBox "Çàïèñü " + CreateCriteria + " íå íàéäåíà", vbInformation, "Ðåçóëüòàòû ïîèñêà"
Else
frmsale.loadRecord
End If
End Sub
 
Public Function CreateCriteria() As String
Dim str As String
If Chktip.Value = 1 Then
str = str + "tip like '*" + Trim(txttip.Text) + "*' And "
End If
If Chkname.Value = 1 Then
str = str + "name like '*" + Trim(txtName.Text) + "*' And "
End If
If Chkscale.Value = 1 Then
str = str + "scale like '*" + Trim(TxtScale.Text) + "*' And "
End If
If Chkaddress.Value = 1 Then
str = str + "address like '*" + Trim(txtaddress.Text) + "*' And "
End If
If chkprise.Value = 1 Then
str = str + "prise like '*" + Trim(txtprise.Text) + "*' And "
End If
If chkdatep.Value = 1 Then
str = str + "datep like '*" + Trim(txtdateP.Text) + "*' And "
End If
If chkbuyname.Value = 1 Then
str = str + "buyname like '*" + Trim(txtBuyName.Text) + "*' And "
End If
If chkGarantyear.Value = 1 Then
str = str + "Garantyear like '*" + Trim(txtGarantyear.Text) + "*' And "
End If
str = Left(str, Len(str) - 5)
CreateCriteria = str
 
End Function