Реализация ГИС VBA

' Ввод данных в строку с номером НомерСтроки рабочего листа

With ActiveSheet

.Cells(НомерСтроки, 1).Value = Фамилия

.Cells(НомерСтроки, 2).Value = Имя

.Cells(НомерСтроки, 3).Value = Пол

.Cells(НомерСтроки, 4).Value = ВыбранныйТур

.Cells(НомерСтроки, 5).Value = Оплачено

.Cells(НдмерСтроки, 6).Value = Фото

.Cells(НомерСтроки, 7).Value = Паспорт

.Cells(НомерСтроки, 8).Value = Срок End With

End Sub

Private Sub CommandButton2_Click()

'Процедура закрытия диалогового окна

'Установка заголовка окна приложения по умолчанию

UserForm1.Hide Application.Caption = Empty ActiveSheet.DrawingObjects.Delete

End Sub

Private Sub SpinButtonl_Change()

'Процедура ввода значения счетчика в поле ввода

With UserForm1

.TextBox3.Text = CStr(.SpinButton1.Value) End With

End Sub

Private Sub TextBox3_Change()

' Процедура установки значения счетчика из поля ввода

With UserForm1

.SpinButton1.Value = CInt(.TextBox3.Text) End With

End Sub

Private Sub ToggleButton1_Click()

' Процедура отображения или удаления поля с текстом

'

If ToggleButton1.Value = True Then

ActiveSheet.DrawingObjects.Delete

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 11.25, 44.25, 106.5, 96)

.Select Selection.Characters.Text = "" With Selection.Font

.Name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 10

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.Colorlndex = xlAutomatic End With Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid Selection.Characters.Text = _

"Программа составлена " & Chr(10) & "ФИО для регистрации " & Chr(10) &_

"клиентов" & Chr(10) & "туристической " & Chr(10) & "фирмы" With

Selection.Characters(Start:=1, Length:=86).Font

.Name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 10

.Strikethrough = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone

.Colorlndex = xlAutomatic End With

End If

If ToggleButton1.Value = False Then ActiveSheet.DrawingObjects.Delete End If

End Sub

'

Private Sub UserForm_Initialize()

'Процедура вызова диалогового окна

'и задание элементов раскрывающегося списка ЗаголовокРабочегоЛиста

'Задание пользовательского заголовка окна приложения Application.Caption = "Регистрация. База данных туристов"

'Закрытие строки формул окна Excel

Application.DisplayFormulaBar = False

'Задание элементов раскрывающегося списка

With CommandButton1

.Default = True

.ControlTipText = "Ввод данных в базу данных" End With

With CommandButton2

.Cancel = True

.ControlTipText = "Кнопка отмены" End With

OptionButton1.Value = True With ToggleButton1

.Value = False

.ControlTipText = "Информация о программе" End With

With ComboBox1

.List = Array("Лондон", "Париж", "Берлин")

.Listlndex = 0 End With

' Активизация диалогового окна

UserForm1.Show End Sub

Sub ЗаголовокРабочегоЛиста()

'Процедура создания заголовков полей базы данных

'Если заголовки существуют, то досрочный выход из процедуры

If Range("Al").Value = "Фамилия" Then Range("A2").Select

Exit Sub

End If

' Если заголовки не существуют, то создаются заголовки полей

ActiveSheet.Cells.Clear

Range("Al:HI").Value = Array("Фамилия", "Имя", "Пол",

"Выбранный Тур", "Оплачено", "Фото", "Паспорт", "Срок")

Range("A:A").ColumnWidth =12 Range("D:D").ColumnWidth = 14.4

'Закрепляется первая строка с тем, чтобы она всегда 'отображалась на экране

Range("2:2").Select ActiveWindow.FreezePanes = True Range("A2").Select

' К каждому заголовку поля базы данных

Range("Al").AddComment Range("Al").Comment.Visible = False Range("Al").Comment.Text Text:="Фамилия клиента" Range("Bl").AddComment Range("Bl").Comment.Visible = False Range("Bl").Comment.Text Text:="Имя клиента" Range("Cl").AddComment Range("Cl").Comment.Visible = False Range("Cl").Comment.Text Text:="Пол клиента" Range("Dl").AddCorament Range("Dl").Comment.Visible = False

Range("Dl").Comment.Text Text:="Направление" & Chr(10) & "выбранного тура" Range("El")

.AddComment Range("El")

.Comment.Visible = False Range("El")

.Comment.Text Text:="Путевка оплачена?" & Chr(10) & "(Да/Нет)"

Range("Fl").AddComment Range("Fl").Comment.Visible = False Range("Fl").Comment.Text Text:="OoTo сданы" & Chr(lO) & "(Да/Нет) "

Range("Gl").AddComment Range("Gl").Comment.Visible = False Range("Gl").Comment.Text Text:="Наличие паспорта" & Chr(10) & "(Да/Нет)"

Range("HI").AddComment Range("HI").Comment.Visible = False Range("HI").Comment.Text Text^"Продолжительность" & Chr(10) &

"поездки"

End Sub

В данной программе для определения первой пустой строки в заполняемой базе данных о туристах используется инструкция

НомерСтроки = Application.CountA(ActiveSheet.Columns(1)) + 1,

правая часть которой вычисляет число непустых ячеек в первом столбце активного рабочего листа. Переменной НомерСтроки присваивается значение на единицу большее, чем число непустых строк, что естественно, т. к. ей должен быть присвоен номер первой непустой строки базы данных. Подобные инструкции довольно часто используется при разработке приложений, поэтому рекомендуем обратить на них внимание.

Процедура ЗаголовокрабочегоЛиста выглядит немножко непонятным. При ее написании лучше всего воспользоваться MacroRecorder, который переведет производимые действия по созданию примечаний пользователем вручную на язык VBA. Итак, для активизации MacroRecorder выберите команду Сервис, Макрос, Начать запись (Tools,

Macro, Record New Macro) и запустите MacroRecorder на запись. После задания всех параметров в появившемся диалоговом окне Запись макроса (Record Macro) и нажатия кнопки ОК появится плавающая панель инструментов с кнопкой Остановить запись (Stop Recording). Теперь все производимые действия будут записываться до тех пор, пока не будет нажата эта кнопка. Постройте примечания по следующему алгоритму. Кроме того, для того чтобы разобраться, как программируется закрепление области на рабочем листе, в этот алгоритм входит также и закрепление первой строки рабочего листа.

1.Щелкните кнопку заголовка второй строки. Вторая строка выделится. Выберите команду Окно, Закрепить области (Window, Freeze Panes).

2.Выделите ячейку A1 и нажмите кнопку Надпись (Textbox) панели инструментов Рисование (Drawing). В появившееся текстовое поле введите текст Фамилия клиента.

3.Выделите ячейку B1 и нажмите кнопку Надпись (TextBox) панели инструментов Рисование (Drawing). В появившееся текстовое поле введите текст имя клиента и т. д. последовательно для ячеек от С1 до H1 .

Перечисленные выше действия будут переведены MacroRecorder в следующий макрос.

Sub Макрос1()

Range("2:2").Select ActiveWindow.FreezePanes = True Range("Al").AddComment Range("A1"}.Comment.Visible = False

Range ("Al"). Comment.Text Тех^="Фамилия клиента" Range("Bl").AddComment Range("Bl").Comment.Visible = False Range("Bl").Comment.Text Text:="Имя клиента" Range("Cl").AddComment Range("Cl").Comment.Visible = False Range("Cl").Comment.Text Text:="Пол клиента" Range("Dl").AddComment Range("Dl").Comment.Visible = False

Range("Dl").Comment.Text Text:="Направление" & Chr(10) & "выбранного тура" Range("El").AddComment Range("El").Comment.Visible = False

Range("El").Comment.Text Text:="Путевка оплачена?" & Chr(10) & "(Да/Нет)"

Range("Fl").AddComnent Range("Fl").Comment.Visible = False

Range("Fl").Comment.Text Text:="Фото сданы" & Chr(10) & "(Да/Нет)"

Range("Gl").AddComment Range("Gl").Comment.Visible = False Range("Gl").Comment.Text Text:="Наличие паспорта" & Chr(10) & " (Да/Нет) "

Range("H1").AddComment Range("H1").Comment.Visible = False Range("H1").Comment.Text Text:="Продолжительность" & Chr(10) &

"поездки"

End Sub

Первые две инструкции записанного макроса показывают, как программно закрепляется область, а остальные – как создаются примечания у ячеек рабочего листа. Теперь, при создании приложения эти фрагменты просто надо вставить в требуемое место набираемой программы.

Аналогично, при написании фрагмента программы, связанного с созданием текстового поля, лучше всего воспользоваться MacroRecorder, который переведет производимые пользователем вручную действия по созданию текстового поля на язык VBA. Итак, для активизации MacroRecorder выберите команду Сервис, Макрос, Начать запись (Tools, Macro, Record New Macro) и запустите MacroRecorder на запись. После задания всех параметров в появившемся диалоговом окне Запись макроса (Record Macro) и нажатия кнопки ОК появится плавающая панель инструментов с кнопкой Остановить запись (Stop Recording). Теперь все производимые действия будут записываться до тех пор, пока не будет нажата эта кнопка. Постройте текстовое поле по алгоритму:

1.Нажмите кнопку Надпись (Textbox) панели Рисование (Drawing) и создайте на рабочем листе текстовое поле.

2.Наберите в текстовом поле следующий текст: Программа составлена ФИО для регистрации клиентов туристической фирмы.

3.Выделите текстовое поле и смените цвет его заливки на желтый, нажав кнопку

Цвет заливки (Fill Color) панели инструментов Рисование (Drawing).

Перечисленные выше действия будут переведены MacroRecorder в следующий макрос.

Sub Макрос2()

'Макрос2 Макрос

ActiveSheet.Shapes. AddTextbox(msoTextOrientationHorizontal, 9.75, 45, _ 108.75, 96).Select

Selection.Characters.Text = _

"Программа составлена " & Chr(10) &

"Андреем Гарнаевым для регистрации " & Chr(10) & "клиентов" & Chr(10) &

"туристической " & Chr(10) & "фирмы" With

Selection.Characters(Start:=1, Length:=86).Font

.Name = "Arial Cyr"

.FontStyle = "обычный"

.Size = 10

.Strikethrough = False

.Superscript = False

.Subscript = False

.OutlineFont = False

.Shadow = False

.Underline = xlUnderlineStyleNone,

.Colorlndex = xlAutomatic

End With Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid

End Sub

Итак, в нашей игре первый ход за пользователем. Ход осуществляется двойным щелчком по игровому полю. Если игровое поле пусто, то в нем отображается крестик. Компьютер мгновенно отвечает на ход игрока, постановкой нолика в другое игровое поле и т. д. О результате игры компьютер информирует пользователя. При желании сыграть еще одну игру с компьютером, нажмите кнопку переиграть, которая очистит игровые поля. На Рис. 2 приведен вид партии в крестики-нолики после второго шага игры.

Рис. 2. Пример партии игры в крестики-нолики после второго шага игры

Крестик и нолик, которые выводятся на игровом поле, содержатся в файлах cross.bmp

иou.bmp, а их образы можно создать при помощи любого графического редактора.

Всвязи с небольшим числом возможных стратегий в этой игре, составляя программу можно пойти по пути наименьшего сопротивления: а именно, применить подход простого перебора вариантов возможных действий. Если бы в игре было большое число стратегий, то этот подход был бы неприменим, т. к. программа не смогла бы играть в режиме реального времени.

Стратегия компьютера в игре крестики-нолики очень проста:

Если в игре сложилась ситуация, когда на очередном ходе он может проставить в ряд три нолика, компьютер ставит их и выигрывает.

Если игрок на очередном ходе угрожает поставить подряд три крестика, а у компьютера есть возможность помешать этому, поставив нолик, он это делает.

Первый и второй ход игры являются основными и здесь компьютер должен действовать осторожно. Поэтому некоторые особые ситуации в них программируются отдельно.

После каждого хода как игрока, так и компьютера необходимо производить проверку на возможный результат игры.

Обсудим, как приведенная ниже программа решает описанную задачу и что в ней происходит.

Рис. 3. Пример сообщения о результате игры

' Переменные уровня модуля

Dim Поле(1 To 3, 1 To 3) As Object Dim Статус(1 To 3, 1 To 3) As Integer

Dim k As Integer

Dim i As Integer

Dim j As Integer

Dim Su(0 To 4, 0 To 4) As Integer

Private Sub CommandButton1_Click()

НачальноеСостояние

End Sub

Private Sub CommandButton2_Click()

UserForm1.Hide

End Sub

Private Sub Label1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Dim Inf As Boolean

If Статус(1, 1) = 0 Then

Поле(1, 1).Picture = LoadPicture("..\cross.bmp")

Статус(1, 1) = 1 k = k + 1

Проверка Inf

If Inf = True Then Exit Sub strategy

Проверка Inf

If Inf = True Then Exit Sub End If

End Sub

Private Sub Label2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Dim Inf As Boolean

If Статус(1, 2) = 0 Then

Поле(1, 2).Picture = LoadPicture("..\cross.bmp")

Статус(1, 2) = 1 k = k + 1

Проверка Inf