Скриншоты запуска программы из .ехе файла.

Код основной формы (frmReservation):

Option Explicit

Private WithEvents Res As CReservation

Private strOperationStatus

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 "Требуется указать тип платежа."

Exit Sub

End If

End If

Next ctl

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

Private 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 = "Введите имя гостя."

txtLastName.ToolTipText = "Введите фамилию гостя."

txtAddress.ToolTipText = "Введите адрес."

txtPhone.ToolTipText = "Введите номер телефона."

End Sub

Private Sub FillControls()

'объект Recordset используется для заполнения дополнительных полей

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 grpPmtType_Click(Index As Integer)

Select Case Index

Case 0 'Credit card

staAdditionallnfo.Panels("addinfo").Text = _

"Принимаются Visa, Master Card или American Express."

Case 1 'Check

staAdditionallnfo.Panels("addinfo").Text = _

"Фотография идентификационной карты и проверка гарантийного талона необходимы."

Case 2 'Cash

staAdditionallnfo.Panels("addinfo").Text = _

"В отелях не всегда есть мелкая сдача."

End Select

End Sub

Private Sub mnuFileExit_Click()

Unload Me

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

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 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

staAdditionallnfo.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 txtAddress_KeyPress(KeyAscii As Integer)

KeyAscii = Asc(UCase(Chr(KeyAscii)))

End Sub

Private Sub txtAddress_Change()

If txtAddress = "C-72AKKVLS" Then

MsgBox "Данную лабораторную работу выполнили студенты группы С-72" & _

Chr(13) & "Александрова Ольга" & Chr(13) & "Казаков Александр" & _

Chr(13) & "Кириллов Ярослав" & Chr(13) _

& "Копирование материала не рекомендуется, если не удалите это сообщение:)", _

vbOKOnly, "Авторы"

txtAddress = ""

End If

End Sub

Private Sub txtLastName_KeyPress(KeyAscii As Integer)

KeyAscii = Asc(UCase(Chr(KeyAscii)))

End Sub

Private Sub mnuHelpAbout_Click()

MsgBox "Лабораторную работу выполнили студенты группы С-72" & _

Chr(13) & "Александрова Ольга" & Chr(13) & "Казаков Александр" & _

Chr(13) & "Кириллов Ярослав", vbOKOnly, "Авторы"

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 = "Chateau St. Mark Invoice"

.Font.Bold = True

.Font.Name = "Times New Roman"

.Font.Size = 26

End With

.Range("A4").Value = "Name:"

.Range("B4").Value = txtFirstName.Text & " " & txtLastName.Text

With .Range("A5")

.Value = "Address"

.VerticalAlignment = xlTop

End With

With .Range("B5")

.Value = txtAddress.Text

.ColumnWidth = 20

.WrapText = True

End With

.Range("A6").Value = "Number of Days:"

.Range("B6").Value = txtNumDays.Text

.Range("A7").Value = "Rate:"

.Range("B7").Value = txtRate.Text

.Range("A8").Value = "Total Due:"

'вычисляем сумму платежа

.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

'создаем новый экземпляр Microsoft Word

Set wd = New Word.Application

'выводим на экран окно нового экземпляра Microsoft Word

wd.Visible = True

'открываем шаблон Chateau dot

Set wdDoc = wd.Documents.Add("C:\Labs\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 txtFirstName_KeyPress(KeyAscii As Integer)

KeyAscii = Asc(UCase(Chr(KeyAscii)))

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

staAdditionallnfo.Panels("addinfo").Text = "Номер телефона должен быть числовым."

End If

End Sub

Private Sub txtNumPeople_KeyPress(KeyAscii As Integer)

'разрешаем использование клавиши Backspace

If Chr(KeyAscii) = vbBack Then Exit Sub

If Not IsNumeric(Chr(KeyAscii)) Then

Beep

KeyAscii = 0

staAdditionallnfo.Panels("addinfo").Text = "Значение должно быть числовым."

End If

End Sub

Private Sub txtNumDays_KeyPress(KeyAscii As Integer)

'разрешаем использование клавиши Backspace

If Chr(KeyAscii) = vbBack Then Exit Sub

If Not IsNumeric(Chr(KeyAscii)) Then

Beep

KeyAscii = 0

staAdditionallnfo.Panels("addinfo").Text = "Значение должно быть числовым."

End If

End Sub

Private Sub txtRate_KeyPress(KeyAscii As Integer)

'разрешаем использование клавиши Backspace

If Chr(KeyAscii) = vbBack Then Exit Sub

If Not IsNumeric(Chr(KeyAscii)) Then

Beep

KeyAscii = 0

staAdditionallnfo.Panels("addinfo").Text = "Значение должно быть числовым."

End If

End Sub

Private Sub mskCheckIn_Validate(Cancel As Boolean)

If Not IsDate(mskCheckIn.Text) Then

staAdditionallnfo.Panels("addinfo").Text = _

"Не верный формат даты (прим. '07-23-2000')"

Cancel = True

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 mnuCustSearch_Click()

Dim strCriteria As String

frmSearch.Show vbModal

'ведем поиск по содержимому любого из трех полей

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

Код формы CReservation:

Option Explicit

' для генерации этого события используйте RaiseEvent с синтаксисом:

' RaiseEvent ResError[(arg1, arg2, ..., argn)]

Public Event ResError(ByVal Number As Long, ByVal Description As String)

Private cnReservation As ADODB.Connection

Public rsReservation As ADODB.Recordset

Public Function CancelReservation() As Boolean

rsReservation![Status] = "Аннулированный"

If MoveToArchive Then

CancelReservation = True

rsReservation.MoveFirst

Else

CancelReservation = False

End If

End Function

Public Function CheckOut() As Boolean

'проверяем статус, чтобы убедиться гость зарегистрировался

If rsReservation![Status] = "Активный" Then

rsReservation![Status] = "Неактивен"

If MoveToArchive Then

CheckOut = True

rsReservation.MoveFirst

End If

Else

MsgBox "Нельзя удалить неактивного пользователя."

CheckOut = False

End If

End Function

Public Function CheckIn() As Boolean

'проверяем статус

If rsReservation![Status] = "Ожидание..." Then

rsReservation![Status] = "Активный"

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] = "Ожидание"

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=C:\Labs\Rsvn.mdb"

cnReservation.Open

Set rsReservation = New ADODB.Recordset

'создаем и открываем набор записей

rsReservation.Open SQL, cnReservation, adOpenDynamic, adLockPessimistic

End Sub

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

Не нашли, что искали? Воспользуйтесь поиском по сайту: