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

Лабораторная работа №11

Содержание данной работы:

· Разработка приложений для Интернета (DHTML-приложений) с помощью VB6.0;

· Преобразование основной формы нашей программы в UserDocument, чтобы ее можно было открывать через веб-браузер.

Выявленные ошибки:

1. Все ошибки, унаследованные от л/р №10.

Скриншот программы, открытой в IE:

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

Option Explicit

Private WithEvents Res As CReservation

Private strOperationStatus

Private Sub UserDocument_Initialize()

Call Form_Load

End Sub

Private Sub adcReservation_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)

Dim strStatus As String

Dim dtCheckIn As Date

Dim intNumDays As Integer

On Error Resume Next

'проверяем способ оплаты (payment type) в базе данных

'и устанавливаем соответствующий переключатель

strStatus = adcReservation.Recordset![PaymentType]

Select Case strStatus

Case "CREDIT CARD"

grpPmtType(0).Value = True

Case "CHECK"

grpPmtType(1).Value = True

Case "CASH"

grpPmtType(2).Value = True

End Select

' присваиваем переменным dtCheckln и intNumDays ,

' значения из набора записей элемента ADO Data

dtCheckIn = adcReservation.Recordset![CheckInDate]

intNumDays = adcReservation.Recordset![NumberOfDays]

' вычисляем дату выписки и выводим ее в txtCheckOut

txtCheckOut.Text = Format(DateAdd("d", intNumDays, dtCheckIn), "mm-dd-yyyy")

End Sub

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

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

'[AXDW] The following line was commented out by the ActiveX Document Migration Wizard.

'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

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

mnuGuestReservationCheckln.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 UserDocument.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 txtFirstName__KeyPress(KeyAscii As Integer)

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

End Sub

Private Sub txtAddress__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 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 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 = _

"Not a valid date format (ex. '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 Checkln() 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

Private Sub Class_Terminate()

End Sub

Лабораторная работа №12

Содержание данной работы:

· Создание и подключение файлов справки в формате Microsoft Help (*.hlp) к проекту на VB6.0.

· Настройка параметров компиляции и, собственно, компиляция исходного кода приложения в исполняемый файл.

· Использование Package and Deployment Wizard для создания дистрибутива приложения, куда, помимо самого исполняемого файла приложения, включаются все необходимые приложению библиотеки и компоненты, а также файл справки.

Выявленные ошибки:

1. Все ошибки, унаследованные от л/р №10.

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