2.2 Текст clsRsvn.cls
Option Explicit
Private cnReservation As ADODB.Connection
Public rsReservation As ADODB.Recordset
Public Event ResError(ByVal Number As Long, ByVal Description As String)
Private Function MoveToArchive() As Boolean
Dim rsArchive As ADODB.Recordset
Set rsArchive = New ADODB.Recordset
On Error GoTo HandleError
rsArchive.Open "ReservationArchive", cnReservation, adOpenDynamic, adLockPessimistic
rsArchive.AddNew
With rsArchive
![FirstName] = rsReservation![FirstName]
![Lastname] = rsReservation![Lastname]
![Address] = rsReservation![Address]
![Phone] = rsReservation![Phone]
![PaymentType] = rsReservation![PaymentType]
![NumberOfPeople] = rsReservation![NumberOfPeople]
![Status] = rsReservation![Status]
![RoomNumber] = rsReservation![RoomNumber]
![Rate] = rsReservation![Rate]
![NumberOfDays] = rsReservation![NumberOfDays]
![CheckInDate] = rsReservation![CheckInDate]
.Update
End With
rsReservation.Delete adAffectCurrent
MoveToArchive = True
Exit Function
HandleError:
MoveToArchive = False
End Function
Public Function CancelReservation() As Boolean
rsReservation![Status] = "CANCELED"
 If MoveToArchive Then
CancelReservation = True
rsReservation.MoveFirst
Else
CancelReservation = False
End If
End Function
Public Function CheckOut() As Boolean
'Check the status to make sure the guest is checked in
If rsReservation![Status] = "ACTIVE" Then
rsReservation![Status] = "INACTIVE"
If MoveToArchive Then
CheckOut = True
rsReservation.MoveFirst
End If
Else
MsgBox "Could not check-out INACTIVE guest."
CheckOut = False
End If
End Function
Public Function CheckIn() As Boolean
If rsReservation![Status] = "PENDING" Then
rsReservation![Status] = "ACTIVE"
rsReservation![CheckInDate] = Format(Date, "mm-dd-yyyy")
rsReservation.Update
CheckIn = True
Else
CheckIn = False
End If
End Function
Public Function AddReservation() As Boolean
rsReservation.AddNew
rsReservation![Status] = "PENDING"
AddReservation = True
End Function
Private Sub Class_GetDataMember(DataMember As String, Data As Object)
Set Data = rsReservation
End Sub
Private Sub Class_Initialize()
Dim SQL As String
SQL = "SELECT * FROM Reservation;"
Set cnReservation = New ADODB.Connection
cnReservation.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;" & _
"Data Source=Rsvn.mdb"
cnReservation.Open
Set rsReservation = New ADODB.Recordset
rsReservation.Open SQL, cnReservation, adOpenDynamic, adLockPessimistic
End Sub
2.3 Текст frmRsvn.frm
S QL = "SELECT * FROM Reservation;"
VERSION 5.00
Object = "{C932BA88-4374-101B-A56C-00AA003668DC}#1.1#0"; "msmask32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmReservation
BorderStyle = 1 'Fixed Single
Caption = "Резервирование отеля"
ClientHeight = 4728
ClientLeft = 2220
ClientTop = 2028
ClientWidth = 7620
Icon = "frmRsvn.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4728
ScaleWidth = 7620
Begin VB.CommandButton cmdMoveLast
Caption = ">>"
Height = 375
Left = 3720
TabIndex = 30
Top = 3720
Width = 735
End
Begin VB.CommandButton cmdMoveNext
Caption = ">"
Height = 375
Left = 3000
TabIndex = 29
Top = 3720
Width = 735
End
Begin VB.CommandButton cmdMovePrevious
Caption = "<"
Height = 375
Left = 2280
TabIndex = 28
Top = 3720
Width = 735
End
Begin VB.CommandButton cmdMoveFirst
Caption = "<<"
Height = 375
Left = 1560
TabIndex = 27
Top = 3720
Width = 735
End
Begin MSComctlLib.StatusBar staAdditionalInfo
Align = 2 'Привязать вниз
Height = 375
Left = 0
TabIndex = 26
Top = 4350
Width = 7620
_ExtentX = 13441
_ExtentY = 656
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 3
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Style = 5
Bevel = 0
TextSave = "1:43"
 Key = "time"
Object.ToolTipText = "The current time"
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Style = 6
TextSave = "03.10.2011"
Key = "date"
Object.ToolTipText = "The current date"
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 8276
Key = "addinfo"
Object.ToolTipText = "Additional Information"
EndProperty
EndProperty
End
Begin VB.CommandButton cmdDone
Caption = "&Готово"
Height = 495
HelpContextID = 10
Left = 5280
TabIndex = 14
Top = 3600
Width = 1215
End
Begin VB.TextBox txtCheckOut
Height = 285
HelpContextID = 28
Left = 5280
Locked = -1 'True
TabIndex = 10
Top = 2400
Width = 1215
End
Begin VB.TextBox txtRate
Height = 285
Left = 5280
TabIndex = 12
Top = 3120
Width = 1215
End
Begin VB.TextBox txtRoomNumber
Height = 285
Left = 5280
TabIndex = 11
Top = 2760
Width = 1215
End
Begin MSMask.MaskEdBox mskCheckIn
Height = 375
HelpContextID = 26
Left = 5280
TabIndex = 8
Top = 1560
Width = 1095
_ExtentX = 1926
_ExtentY = 656
_Version = 393216
MaxLength = 10
Mask = "##-##-####"
PromptChar = "_"
End
Begin VB.TextBox txtPhone
Height = 285
Left = 1440
TabIndex = 3
Top = 3120
Width = 1935
End
Begin VB.Frame fraPmtType
Caption = "Тип платежа:"
Height = 615
HelpContextID = 9
Left = 3600
TabIndex = 13
Top = 480
Width = 3375
Begin VB.OptionButton grpPmtType
Caption = "Наличка"
Height = 255
HelpContextID = 9
Index = 2
Left = 2160
TabIndex = 6
Top = 240
Width = 1095
End
Begin VB.OptionButton grpPmtType
Caption = "Чек"
Height = 255
HelpContextID = 9
Index = 1
Left = 1320
TabIndex = 5
Top = 240
Width = 855
End
Begin VB.OptionButton grpPmtType
Caption = "Кредитка"
Height = 255
HelpContextID = 9
Index = 0
Left = 120
TabIndex = 4
Top = 240
Width = 1215
End
End
Begin VB.TextBox txtNumDays
Height = 285
HelpContextID = 27
Left = 5280
MaxLength = 3
TabIndex = 9
Top = 2040
Width = 375
End
Begin VB.TextBox txtNumPeople
Height = 285
HelpContextID = 25
Left = 5280
MaxLength = 3
TabIndex = 7
Top = 1200
Width = 495
End
Begin VB.TextBox txtAddress
 Height = 1125
Left = 1440
MaxLength = 75
MultiLine = -1 'True
ScrollBars = 2 'Вертикаль
TabIndex = 2
Top = 1920
Width = 1935
End
Begin VB.TextBox txtLastName
Height = 285
HelpContextID = 22
Left = 1440
TabIndex = 1
Top = 1560
Width = 1935
End
Begin VB.TextBox txtFirstName
Height = 285
HelpContextID = 21
Left = 1440
TabIndex = 0
Top = 1200
Width = 1935
End
Begin VB.Label lblReservation
Caption = "Цена:"
Height = 255
Index = 14
Left = 3600
TabIndex = 25
Top = 3120
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Номер комнты:"
Height = 255
Index = 12
Left = 3600
TabIndex = 24
Top = 2760
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Дата выезда:"
Height = 255
Index = 10
Left = 3600
TabIndex = 23
Top = 2400
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Число дней:"
Height = 255
Index = 9
Left = 3600
TabIndex = 22
Top = 2040
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Дата въезда:"
Height = 255
 Index = 8
Left = 3600
TabIndex = 21
Top = 1560
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Кол-во людей:"
Height = 255
Index = 7
Left = 3600
TabIndex = 20
Top = 1200
Width = 1575
End
Begin VB.Label lblReservation
Caption = "Телефон:"
Height = 255
Index = 6
Left = 120
TabIndex = 19
Top = 3120
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Адрес:"
Height = 255
Index = 2
Left = 120
TabIndex = 18
Top = 1920
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Фамилия:"
Height = 255
Index = 1
Left = 120
TabIndex = 17
Top = 1560
Width = 1215
End
Begin VB.Label lblReservation
Caption = "Имя:"
Height = 255
Index = 0
Left = 120
TabIndex = 16
Top = 1200
Width = 1215
End
Begin VB.Label lblHotelResSystem
Caption = "Система бронирования номеров в отеле «Парус»"
BeginProperty Font
Name = "MS Sans Serif"
Size = 13.2
Charset = 204
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 15
Top = 120
Width = 7335
End
Begin VB.Menu mnuFile
Caption = "&Файл"
Begin VB.Menu mnuFileExit
Caption = "Выход"
End
End
Begin VB.Menu mnuGuest
Caption = "Гость"
Begin VB.Menu mnuGuestReservation
Caption = "&Резервирование"
Begin VB.Menu mnuGuestReservationAdd
Caption = "&Добавить"
Shortcut = ^N
End
Begin VB.Menu mnuGuestReservationCheckIn
Caption = "Въезд"
Shortcut = ^I
End
Begin VB.Menu mnuGuestReservationCheckout
Caption = "Выезд"
Shortcut = ^O
End
Begin VB.Menu mnuGuestReservationCancel
Caption = "&Отмениь бронь"
Shortcut = +{DEL}
End
End
Begin VB.Menu mnuCustSearch
Caption = "&Поиск"
End
Begin VB.Menu mnuGuestEdit
Caption = "&Редактировать запись"
End
End
Begin VB.Menu mnuReports
Caption = "&Отчеты"
Begin VB.Menu mnuReportsReminder
Caption = "&Напоминание"
End
Begin VB.Menu mnuReportsInvoice
Caption = "&Счёт"
End
End
Begin VB.Menu mnuHelp
Caption = "&Помощь"
Begin VB.Menu mnuHelpContents
Caption = "&Содержание..."
End
Begin VB.Menu mnuHelpAbout
Caption = "&О программе"
End
End
End
Attribute VB_Name = "frmReservation"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private WithEvents Res As CReservation
A ttribute Res.VB_VarHelpID = -1
Private Sub cmdDone_Click()
Dim ctl As Control
For Each ctl In Controls
If TypeOf ctl Is TextBox Then
If ctl.Text = "" Then
MsgBox "Все поля должны быть заполнены"
Exit Sub
End If
ElseIf TypeOf ctl Is MaskEdBox Then
If ctl.ClipText = "" Then
MsgBox "Все поля должны быть заполнены"
Exit Sub
End If
'ElseIf TypeOf ctl Is OptionButton Then
' If ctl.Value = "" Then
' MsgBox "Payment type is required."
' Exit Sub
'End If
End If
Next ctl
If Not (grpPmtType(0).Value) And Not (grpPmtType(1).Value) And Not (grpPmtType(2).Value) Then
'вот если Value всех трех радиокнопок равен False, тогда считаем, что вид платежа не указан.
MsgBox "Необходимо указать вид платежа.", vbExclamation, "Ошибка"
Exit Sub
End If
DisableControls
If grpPmtType(0).Value Then
Res.rsReservation![PaymentType] = "CREDIT CARD"
ElseIf grpPmtType(1).Value Then
Res.rsReservation![PaymentType] = "CHECK"
ElseIf grpPmtType(2).Value Then
Res.rsReservation![PaymentType] = "CASH"
End If
Res.rsReservation![CheckInDate] = mskCheckIn.Text
Res.rsReservation.Update
End Sub
Private Sub cmdMoveFirst_Click()
Res.rsReservation.MoveFirst
FillControls
End Sub
Private Sub cmdMoveLast_Click()
Res.rsReservation.MoveLast
FillControls
End Sub
Private Sub cmdMoveNext_Click()
With Res.rsReservation
.MoveNext
If .EOF Then
.MoveFirst
End If
End With
FillControls
End Sub
P rivate Sub cmdMovePrevious_Click()
With Res.rsReservation
.MovePrevious
If .BOF Then
.MoveLast
End If
End With
FillControls
End Sub
Private Sub Form_Load()
Set Res = New CReservation
DisableControls
Set txtFirstName.DataSource = Res
txtFirstName.DataField = "FirstName"
Set txtLastName.DataSource = Res
txtLastName.DataField = "LastName"
Set txtAddress.DataSource = Res
txtAddress.DataField = "Address"
Set txtPhone.DataSource = Res
txtPhone.DataField = "Phone"
Set txtNumPeople.DataSource = Res
txtNumPeople.DataField = "NumberOfPeople"
Set txtNumDays.DataSource = Res
txtNumDays.DataField = "NumberOfDays"
Set txtRoomNumber.DataSource = Res
txtRoomNumber.DataField = "RoomNumber"
Set txtRate.DataSource = Res
txtRate.DataField = "Rate"
FillControls
txtFirstName.ToolTipText = "Enter the guest's first name."
txtLastName.ToolTipText = "Enter the guest's last name."
End Sub
Private Sub grpPmtType_Click(Index As Integer)
Select Case Index
Case 0
staAdditionalInfo.Panels("addinfo").Text = _
"Visa, Master Card или American Express допустимы."
Case 1
staAdditionalInfo.Panels("addinfo").Text = _
"Требуется удостоверение личности"
Case 2
staAdditionalInfo.Panels("addinfo").Text = _
"Отели не заботся о дополнительных изменениях."
End Select
End Sub
Private Sub mnuCustSearch_Click()
Dim strCriteria As String
frmSearch.Show vbModal
'Поиск по какому либо из 3-х полей
If Trim(frmSearch!txtLastName.Text) <> "" Then
strCriteria = "[LastName] LIKE '" & frmSearch!txtLastName.Text & "%'"
ElseIf Trim(frmSearch!txtPhone.Text) <> "" Then
strCriteria = "[Phone] LIKE '" & frmSearch!txtPhone.Text & "%'"
ElseIf Trim(frmSearch!txtFirstName.Text) <> "" Then
strCriteria = "[FirstName] LIKE '" & frmSearch!txtFirstName.Text & "%'"
End If
With Res.rsReservation
'Фамилии
.Find strCriteria
'Не найдена
If .EOF Then
MsgBox "Фамилия " & frmSearch!txtLastName.Text & " не найдена."
End If
End With
Unload frmSearch
End Sub
Private Sub mnuGuestEdit_Click()
EnableControls
End Sub
Private Sub mnuGuestReservationAdd_Click()
Dim ctl As Control
Res.AddReservation
EnableControls
For Each ctl In frmReservation.Controls
If TypeOf ctl Is TextBox Then
ctl.Text = ""
ElseIf TypeOf ctl Is MaskEdBox Then
ctl.Text = "__-__-____"
ElseIf TypeOf ctl Is OptionButton Then
ctl.Value = False
End If
Next
txtFirstName.SetFocus
staAdditionalInfo.Panels("addinfo").Text = _
"Нажмите 'Готово' чтобы обновиь таблицу."
End Sub
Private Sub mnuGuestReservationCancel_Click()
Res.CancelReservation
End Sub
Private Sub mnuGuestReservationCheckIn_Click()
Dim blnCheckInResult As Boolean
blnCheckInResult = Res.CheckIn()
If blnCheckInResult Then
MsgBox "Гость успешно въехал."
Else
MsgBox "Не возможно вписать гостя. Статус: " & _
Res.rsReservation![Status]
End If
End Sub
Private Sub mnuGuestReservationCheckout_Click()
Res.CheckOut
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub FillControls()
mskCheckIn.Text = Format(Res.rsReservation![CheckInDate], "mm-dd-yyyy")
 txtCheckOut.Text = Format(DateAdd("d", Val(txtNumDays.Text), mskCheckIn.Text), "mm-dd-yyyy")
Select Case Res.rsReservation![PaymentType]
Case "CREDIT CARD"
grpPmtType(0).Value = True
Case "CHECK"
grpPmtType(1).Value = True
Case "CASH"
grpPmtType(2).Value = True
End Select
End Sub
Private Sub DisableControls()
Dim ctl As Control
For Each ctl In Controls
If TypeOf ctl Is Menu Or TypeOf ctl Is Label Then
ctl.Enabled = True
Else
ctl.Enabled = False
End If
If TypeOf ctl Is TextBox Or TypeOf ctl Is MaskEdBox _
Then ctl.BackColor = "&H8000000F"
Next ctl
mnuGuestReservationCheckIn.Enabled = False
mnuGuestReservationCheckout.Enabled = False
mnuGuestReservationCancel.Enabled = False
cmdMoveFirst.Enabled = True
cmdMovePrevious.Enabled = True
cmdMoveNext.Enabled = True
cmdMoveLast.Enabled = True
End Sub
Private Sub EnableControls()
Dim ctl As Control
For Each ctl In Controls
ctl.Enabled = True
If TypeOf ctl Is TextBox Or TypeOf ctl Is MaskEdBox _
Then ctl.BackColor = "&H80000005"
Next ctl
mnuGuestReservationCheckIn.Enabled = True
mnuGuestReservationCheckout.Enabled = True
mnuGuestReservationCancel.Enabled = True
cmdMoveFirst.Enabled = False
cmdMovePrevious.Enabled = False
cmdMoveNext.Enabled = False
cmdMoveLast.Enabled = False
End Sub
Private Sub mnuHelpAbout_Click()
MsgBox "Лабораторная работа выполнена студентами группы С-73 Безденежных Юлией, Березиной Кристиной, Ковтуненко Константином"
End Sub
Private Sub mnuHelpContents_Click()
Shell "cmd /X /C start help.doc"
End Sub
Private Sub mnuReportsInvoice_Click()
Static xl As Excel.Application
Set xl = New Excel.Application
With xl
 .Visible = True
.Workbooks.Add
With .Range("A1")
.Value = "Счёт отеля Парус"
.Font.Bold = True
.Font.Name = "Times New Roman"
.Font.Size = 26
End With
.Range("A4").Value = "Имя:"
.Range("B4").Value = txtFirstName.Text & " " & txtLastName.Text
With .Range("A5")
.Value = "Адрес"
.VerticalAlignment = xlTop
End With
With .Range("B5")
.Value = txtAddress.Text
.ColumnWidth = 20
.WrapText = True
End With
.Range("A6").Value = "Число дней:"
.Range("B6").Value = txtNumDays.Text
.Range("A7").Value = "Цена:"
.Range("B7").Value = txtRate.Text
.Range("A8").Value = "Итого:"
.Range("B8").Value = Format(CSng(txtNumDays.Text) * CSng(txtRate.Text), "Currency")
'Остальное
End With
Columns("A:A").ColumnWidth = 25
xl.ActiveWorkbook.PrintPreview
End Sub
Private Sub mnuReportsReminder_Click()
Static wd As Word.Application
Static wdDoc As Word.Document
Dim strPmtType As String
Set wd = New Word.Application
wd.Visible = True
Set wdDoc = wd.Documents.Add(App.Path & "\Chateau.dot")
If grpPmtType(0).Value = True Then
strPmtType = "Credit Card"
ElseIf grpPmtType(1).Value Then
strPmtType = "Check"
Else
strPmtType = "Cash"
End If
With wdDoc
.FormFields("wdFirstName").Range = txtFirstName.Text
.FormFields("wdCheckIn").Range = mskCheckIn.Text
.FormFields("wdNumOfDays").Range = txtNumDays.Text
.FormFields("wdPmtType").Range = strPmtType
.FormFields("wdCalcTotal").Range = Format(CSng(txtNumDays.Text) * CSng(txtRate.Text), "Currency")
.FormFields("wdCheckOut").Range = txtCheckOut.Text
End With
wdDoc.PrintPreview
End Sub
Private Sub mskCheckIn_Validate(Cancel As Boolean)
If Not IsDate(mskCheckIn.Text) Then
staAdditionalInfo.Panels("addinfo").Text = "Некорректный формат даты (прим. '07-23-2000')"
Cancel = True
End If
End Sub
Private Sub txtAddress_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub
Private Sub txtFirstName_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub
Private Sub txtLastName_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub
Private Sub txtNumDays_KeyPress(KeyAscii As Integer)
If Chr(KeyAscii) = vbBack Then Exit Sub
If Not IsNumeric(Chr(KeyAscii)) Then
Beep
KeyAscii = 0
staAdditionalInfo.Panels("addinfo").Text = "Значение должно быть числовым"
End If
End Sub
Private Sub txtNumDays_LostFocus()
If mskCheckIn.ClipText <> "" And txtNumDays.Text <> "" Then
txtCheckOut.Text = Format(DateAdd("d", Val(txtNumDays.Text), mskCheckIn.Text), "mm-dd-yyyy")
End If
End Sub
Private Sub txtNumPeople_KeyPress(KeyAscii As Integer)
If Chr(KeyAscii) = vbBack Then Exit Sub
If Not IsNumeric(Chr(KeyAscii)) Then
Beep
KeyAscii = 0
staAdditionalInfo.Panels("addinfo").Text = "Значение должно быть числовым"
End If
End Sub
Private Sub txtPhone_KeyPress(KeyAscii As Integer)
If Chr(KeyAscii) = vbBack _
Or Chr(KeyAscii) = "-" _
Or Chr(KeyAscii) = "(" _
Or Chr(KeyAscii) = ")" Then Exit Sub
If Not IsNumeric(Chr(KeyAscii)) Then
Beep
KeyAscii = 0
staAdditionalInfo.Panels("addinfo").Text = "Телефон должен быть числовым"
End If
End Sub
Private Sub txtRate_KeyPress(KeyAscii As Integer)
If Chr(KeyAscii) = vbBack Then Exit Sub
If Not IsNumeric(Chr(KeyAscii)) Then
Beep
KeyAscii = 0
staAdditionalInfo.Panels("addinfo").Text = "Значение должно быть числовым"
End If
End Sub
|
