Библиографический список

1. Delphi 7 / под. общ. ред. А.Д. Хомоненко. – СПб.: БХВ-Петербург, 2008. – 1216 с.: ил.

2. VBA для "чайников", 3-е издание. : Пер. с англ. — М. : Издательский дом "Вильяме", 2001. — 448 с. : ил. — Парал. тит. англ.

Приложение приложение а Листинг программы «Работа интернет клуба» в Microsoft Excel на языке Visual Basic For Application

Модуль main

Public Sub refresh() 'подпрограмма обновления основных переменных

rb = 6

cb = 2

ckol = 9

kol 'вызов подпрограммы подсчета количества записей

End Sub

Private Sub bAdd_Click() 'вызов формы добавления записи

refresh 'вызов подпрограммы обновления основных переменных

row1 = rkol + rb

fAdd.Caption = "Добавить данные" 'Изменяем заголовок формы

'Очищаем поля, подготавливаем их для ввода новых данных

fAdd.tbnum.Text = ""

fAdd.tbpolz.Text = ""

fAdd.tbnach.Text = ""

fAdd.tbtimer.Text = ""

fAdd.tbtar.Text = ""

fAdd.tbskid.Text = ""

fAdd.tbusl.Text = ""

fAdd.Show 'Показываем форму

End Sub

Public Sub kol() 'подпрограмма подсчета количества строк в таблице

If IsEmpty(Cells(rb, cb)) Then 'проверяем на пустое значение первую ячейку таблицы, если пустая обнуляем счетчики

rkol = 0

ind = 0

Else 'если нет то продолжаем подсчет записей

i = 0

Do While Not IsEmpty(Cells(rb + i, cb))

i = i + 1

Loop

rkol = i

ind = Val(Cells(rb + rkol - 1, cb)) 'номеру изменяемой записи присваиваем номер последней

End If

lkol.Caption = "Количество записей - " + Str(rkol) 'выводим данные о количестве записей в label на листе

End Sub

Private Sub bDel_Click() 'подпрограмма удаления выбранной записи

refresh

'проверка находится ли выбранная ячейка в нужном диапазоне

If (ActiveCell.Row >= rb) And (ActiveCell.Row < rb + rkol) And (ActiveCell.Column >= cb) And (ActiveCell.Column < cb + ckol) Then

If MsgBox("Удалить запись?", vbYesNo, "Потверждение удаления") = vbYes Then 'организуем диалог потверждения удаления записи

Rows(ActiveCell.Row).Delete

refresh

For i = 1 To rkol 'обновляем нумерацию в первом столбце

Cells(rb + i - 1, cb) = Str(i)

Next i

End If

Else

MsgBox "Неверный диапазон" 'сообщение которое выводится если выбранная ячейка находится вне диапозона

End If

End Sub

Private Sub bEdit_Click() 'вызов формы для редактирования записи

refresh

If (ActiveCell.Row >= rb) And (ActiveCell.Row < rb + rkol) And (ActiveCell.Column >= cb) And (ActiveCell.Column < cb + ckol) Then

row1 = ActiveCell.Row

ind = Val(Cells(row1, cb) - 1) 'определяем и сохраняем номер редактируемой записи в переменную ind

'заполняем поля формы уже введенными значениями

fAdd.tbnum.Text = Cells(row1, cb + 1)

fAdd.tbpolz.Text = Cells(row1, cb + 2)

fAdd.tbnach.Text = Cells(row1, cb + 3)

fAdd.tbtimer.Text = Cells(row1, cb + 4)

fAdd.tbtar.Text = Cells(row1, cb + 5)

fAdd.tbskid.Text = Cells(row1, cb + 6)

fAdd.tbusl.Text = Cells(row1, cb + 7)

fAdd.Caption = "Изменить данные"

fAdd.Show

Else

MsgBox "Неверный диапазон"

End If

End Sub

Private Sub bFind_Click() 'вызываем форму введения критериев поиска

fFind.tbfind.Text = "" 'очищаем поле в котором вводится искомое значение

fFind.Show

End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 'подпрограмма срабатывающая при изменении содержимого листа

refresh

End Sub

Forms FAdd

Private Sub bCancel_Click() 'подпрограмма для обработки собития нажатия кнопки "Отмена"

fAdd.Hide 'закрытие формы

End Sub

Private Sub bSave_Click() 'подпрограмма для обработки события нажатия кнопки "Сохранить"

'переносим информацию из текстовых полей в сооствествующие ячейки листа

main.Cells(main.row1, main.cb) = Str(main.ind + 1)

main.Cells(main.row1, main.cb + 1) = fAdd.tbnum.Text

main.Cells(main.row1, main.cb + 2) = fAdd.tbpolz.Text

main.Cells(main.row1, main.cb + 3) = fAdd.tbnach.Text

main.Cells(main.row1, main.cb + 4) = fAdd.tbtimer.Text

main.Cells(main.row1, main.cb + 5) = fAdd.tbtar.Text

main.Cells(main.row1, main.cb + 6) = fAdd.tbskid.Text

main.Cells(main.row1, main.cb + 7) = fAdd.tbusl.Text

main.Cells(main.row1, main.cb + 8) = fAdd.tbtimer.Text * fAdd.tbtar.Text + fAdd.tbusl.Text - ((fAdd.tbtimer.Text * fAdd.tbtar.Text * fAdd.tbskid.Text) / 100)

'рисуем границы ячеек и заливаем серым цветом первые ячейки строки

main.Range(main.Cells(main.row1, main.cb), main.Cells(main.row1, main.cb + main.ckol - 1)).Select 'выбираем нужный диапозон ячеек

'для выбранного диапазона рисуем границы

With Selection.Borders(xlEdgeLeft) 'внешние левые линии

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeTop) 'внешние верхние линии

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeBottom) 'внешние нижние линии

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeRight) 'внешние правые линии

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlInsideVertical) 'внутренние вертикальные линии

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

'заливаем первые ячейки строки серым цветом

With main.Cells(main.row1, main.cb).Interior

.ColorIndex = 4

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

MsgBox "Данные сохранены"

fAdd.Hide

End Sub

Forms FFind

Private Sub bFind_Click() 'подпрограмма для обработки события нажатия кнопки "Найти"

If tbfind.Text <> "" Then 'проверяем на пустое значения поле ввода, если не равно то поиск выполняется

StrFind = tbfind.Text

main.Cells(1, 1).Activate

'в переменную fresult помещаем результаты стандартного поиска Excell

Set fresult = main.Cells.Find(What:=StrFind, After:=ActiveCell, LookIn:=xlFormulas, LookAt _

:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _

False, SearchFormat:=False)

If Not fresult Is Nothing Then 'проверяем результа поиска, если не пустой, то продолжаем процедуру

main.refresh

resfind.Cells.Clear 'очищаем лист с результатами поиска

rb = 3 'номер первой строки

cb = 3 'номер первого столбца

ckol = main.ckol 'количество столбцов (должно совпадать с количеством на главной странице)

'заполняем шапку таблицы

resfind.Cells(rb, cb).Value = main.Cells(main.rb - 1, main.cb).Value

resfind.Cells(rb, cb + 1).Value = main.Cells(main.rb - 1, main.cb + 1).Value

resfind.Cells(rb, cb + 2).Value = main.Cells(main.rb - 1, main.cb + 2).Value

resfind.Cells(rb, cb + 3).Value = main.Cells(main.rb - 1, main.cb + 3).Value

resfind.Cells(rb, cb + 4).Value = main.Cells(main.rb - 1, main.cb + 4).Value

resfind.Cells(rb, cb + 5).Value = main.Cells(main.rb - 1, main.cb + 5).Value

resfind.Cells(rb, cb + 6).Value = main.Cells(main.rb - 1, main.cb + 6).Value

resfind.Cells(rb, cb + 7).Value = main.Cells(main.rb - 1, main.cb + 7).Value

resfind.Cells(rb, cb + 8).Value = main.Cells(main.rb - 1, main.cb + 8).Value

fresult.Activate 'активируем набор с результами поиска

firstaddress = ActiveCell.Address 'активируем первую ячейку результатов поиска

'копируем первую найденную строку с главного листа на лист с результатами поиска

resfind.Cells(rb + 1, cb).Value = main.Cells(ActiveCell.Row, main.cb).Value

resfind.Cells(rb + 1, cb + 1).Value = main.Cells(ActiveCell.Row, main.cb + 1).Value

resfind.Cells(rb + 1, cb + 2).Value = main.Cells(ActiveCell.Row, main.cb + 2).Value

result.Cells(rb + 1, cb + 3).Value = main.Cells(ActiveCell.Row, main.cb + 3).Value

resfind.Cells(rb + 1, cb + 4).Value = main.Cells(ActiveCell.Row, main.cb + 4).Value

resfind.Cells(rb + 1, cb + 5).Value = main.Cells(ActiveCell.Row, main.cb + 5).Value

resfind.Cells(rb + 1, cb + 6).Value = main.Cells(ActiveCell.Row, main.cb + 6).Value

resfind.Cells(rb + 1, cb + 7).Value = main.Cells(ActiveCell.Row, main.cb + 7).Value

resfind.Cells(rb + 1, cb + 8).Value = main.Cells(ActiveCell.Row, main.cb + 8).Value

kol = 2

Do

'проверяем на совпадение с предыдущей записью, если не совпадает то выводим если да то не выводим

If main.Cells(ActiveCell.Row, main.cb) <> resfind.Cells(rb + kol - 1, cb).Value Then

resfind.Cells(rb + kol, cb).Value = main.Cells(ActiveCell.Row, main.cb).Value

resfind.Cells(rb + kol, cb + 1).Value = main.Cells(ActiveCell.Row, main.cb + 1).Value

resfind.Cells(rb + kol, cb + 2).Value = main.Cells(ActiveCell.Row, main.cb + 2).Value

resfind.Cells(rb + kol, cb + 3).Value = main.Cells(ActiveCell.Row, main.cb + 3).Value

resfind.Cells(rb + kol, cb + 4).Value = main.Cells(ActiveCell.Row, main.cb + 4).Value

resfind.Cells(rb + kol, cb + 5).Value = main.Cells(ActiveCell.Row, main.cb + 5).Value

resfind.Cells(rb + kol, cb + 6).Value = main.Cells(ActiveCell.Row, main.cb + 6).Value

resfind.Cells(rb + kol, cb + 7).Value = main.Cells(ActiveCell.Row, main.cb + 7).Value

resfind.Cells(rb + kol, cb + 8).Value = main.Cells(ActiveCell.Row, main.cb + 8).Value

kol = kol + 1 'увеличиваем счетчик выведеных записей на 1

End If

main.Cells.FindNext(After:=ActiveCell).Activate 'переходим к следующей найденной записи

Loop While Not firstaddress = ActiveCell.Address 'если достигаем первой записи прекращаем вывод

kol = kol - 1

MsgBox "Найдено значений - " + Str(kol)

fFind.Hide

resfind.Activate

'заливаем зеленым цветом ячейки шапки таблицы

resfind.Range(resfind.Cells(rb, cb), resfind.Cells(rb, cb + ckol - 1)).Select 'выбираем шапку таблицы

'заливаем выделенные ячейки зеленым цветом

With Selection.Interior

.ColorIndex = 4

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

resfind.Range(resfind.Cells(rb, cb), resfind.Cells(rb + kol, cb + ckol - 1)).Select 'выбираем ячейки содержащие данные

'Изменяем ширину столбцов по содержимому

Selection.Columns.AutoFit

'рисуем границы выделенных ячеек

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

With Selection.Borders(xlInsideHorizontal) 'внутренние вертикальные линии

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

Else

MsgBox "Ничего не найдено"

End If

Else

MsgBox "Введите искомое значение"

End If

End Sub