Дата публикации статьи: 09.07.2003 00:00

Лирическое отступление 1. Основная сложность в создании защитников экрана заключается в невозможности проведения полноценной отладки. Поэтому я рекомендую, когда Вы будете создавать СВОИ защитники, отлаживайте отдельные блоки в другом проекте. Если ошибок нет, переносите свой код в приложение. Далее необходимо скомпилировать проект и готовый scr-файл скопировать в директорию \\… Windows\System. Второй вариант – запуск готового приложения через кнопку Пуск, меню Выполнить (т.е. через командную строку).



Шаг 6. Добавим еще один таймер, который будет отслеживать передвижение нашей бегущей строки.

Name = tmrRunString
Enabled = False
Interval = 50

В разделе деклараций объявим еще три переменные. Две, отвечающие за координаты выводимой записи, и одну - за текст выводимой записи.

Dim lngPosX As Long
Dim lngPosY As Long
Dim txtRunString As String

В теле процедуры сначала очищаем от предыдущей графики, затем изменяем переменную, отвечающую за координату Х (по горизонтали). Делаем проверку, не ушла ли надпись за край экрана и если ушла, то обращаемся в процедуру TypeMove (к ней мы вернемся позже) для изменения переменной, отвечающей за координату Y (по вертикали). После этого, присваиваем текущим координатам значения переменных и выводим на печать.

Private Sub tmrRunString_Timer()
Cls
lngPosX = lngPosX - 50
If lngPosX <= -TextWidth(txtRunString) Then
TypeMove
End If
CurrentX = lngPosX
CurrentY = lngPosY
Print txtRunString
End Sub



Шаг 7. Вернемся к форме frmSSetup и расположим на ней различные элементы управления.

Кнопку настроек и лейбл для отображения шрифта:

Name = cmdOption
Caption = "Настроить"

**********************************

Name = lblSample
BorderStyle = 1 (Fixed Single)
Caption = "Образец шрифта"

Кнопку и список для заполнения "умными мыслями"

Name = cmdText
Caption = "Текст"

*********************

Name = lstText

И две радиокнопки

Name = optMove
Caption = "По центру"
Index = 0

***************************

Name = optMove
Caption = "Случайно"
Index = 1

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

Caption = "mnuOption"
Name = mnuOption
Visible = False

******************

Caption = "Цвет фона"
Name = mnuOption1
Index = 0
Visible = True

******************

Caption = "Шрифт"
Name = mnuOption1
Index = 1
Visible = True

И аналогичное меню с подменю для другой кнопки:

Caption = " mnuText"
Name = mnuText
Visible = False

******************

Caption = "Добавить"
Name = mnuText1
Index = 0
Visible = True

******************

Caption = "Редактировать"
Name = mnuText1
Index = 1
Visible = True

******************

Caption = "Удалить"
Name = mnuText1
Index = 2
Visible = True

Теперь перейдем в коды и привяжем контекстные меню к кнопкам.

Private Sub cmdOption_Click()
PopupMenu mnuOption, , cmdOption.Left + 60, _
cmdOption.Top + cmdOption.Height
End Sub



Private Sub cmdText_Click()
PopupMenu mnuText, , cmdText.Left + 60, cmdText.Top + cmdText.Height
End Sub

В конце этого шага добавим еще один элемент управления – CommonDialog. Изменим только его название: Name = dlgFont.



Шаг 8. Подготовительные работы закончились и переходим непосредственно к кодированию.

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

Private Sub Form_Load()
Dim i As Integer
Dim txtSetting As Variant
lblSample.Font.Charset = GetSetting(App.EXEName, "Option", _
"FontCharset", 204)
lblSample.FontBold = GetSetting(App.EXEName, "Option", "FontBold", False)
lblSample.FontItalic = GetSetting(App.EXEName, "Option", _
"FontItalic", False)
lblSample.FontName = GetSetting(App.EXEName, "Option", _
"FontName", "Verdana, Arial Cyr")
lblSample.FontSize = GetSetting(App.EXEName, "Option", "FontSize", 8)
lblSample.FontStrikethru = GetSetting(App.EXEName, "Option", _
"FontStrikethru", False)
lblSample.FontUnderline = GetSetting(App.EXEName, "Option", _
"FontUnderline", False)
lblSample.ForeColor = GetSetting(App.EXEName, "Option", _
"ForeColor", &HFF00FF)
lblSample.BackColor = GetSetting(App.EXEName, "Option", "BackColor", 0)
optMove(GetSetting(App.EXEName, "Option", "Move", "0")).Value = True
On Error GoTo LocalErr

txtSetting = GetAllSettings(App.EXEName, "Texts")
For i = LBound(txtSetting, 1) To UBound(txtSetting, 1)
lstText.AddItem txtSetting(i, 1)
Next
Exit Sub



LocalErr:
lstText.AddItem "Посетите сайт ""VisualBasic Streets"""
End Sub



NB! Первой строкой идет сохранение кодировки. К моему сожалению, я не нашел у данного контрола свойства, сохраняющего кодировку шрифта. Кириллица = 204.



Лирическое отступление 2. Немного подробнее о функции GetAllSettings. Вначале считываем в переменную все содержание указанной секции. Переменная должна быть Variant, так как она содержит массив данных. В нашем случае если мы попросим переменную показать данные с параметрами txtSetting(1,0) – то увидим НАЗВАНИЕ первого параметра ("Т0"). А если с параметрами txtSetting(1,1) – то ЗНАЧЕНИЕ этого же параметра ("Посетите сайт "Visual Basic Streets""). Как рекомендация, перед работой с данной функцией сделайте обработку ошибок на случай отсутствия записей.



Шаг 9. Займемся обработкой нажатия меню. Ничего сложного в этих кодах нет, поэтому предлагаю самим разобраться. Интерес представляет свойство Flags для CommonDialog. Первый параметр говорит о том, чтобы загружались и экранные и принтерные шрифты. Второй – о выводе дополнительных опций: подчеркнутый, зачеркнутый и цвет.

Private Sub mnuOption1_Click(Index As Integer)
On Error GoTo LocalErr
dlgFont.CancelError = True
Select Case Index
Case 0 'цвет
With dlgFont
.DialogTitle = "Изменение цвета фона"
.Color = GetSetting(App.EXEName, "Option", _
"BackColor", lblSample.BackColor)
.ShowColor
lblSample.BackColor = .Color
End With

Case 1 'фонт
With dlgFont
.DialogTitle = "Выбор шрифта"
.Flags = cdlCFBoth + cdlCFEffects
.FontBold = GetSetting(App.EXEName, "Option", _
"FontBold", lblSample.FontBold)
.FontItalic = GetSetting(App.EXEName, "Option", _
"FontItalic", lblSample.FontItalic)
.FontName = GetSetting(App.EXEName, "Option", _
"FontName", lblSample.FontName)
.FontSize = GetSetting(App.EXEName, "Option", _
"FontSize", lblSample.FontSize)
.FontStrikethru = GetSetting(App.EXEName, _
"Option", "FontStrikethru", lblSample.FontStrikethru)
.FontUnderline = GetSetting(App.EXEName, _
"Option", "FontUnderline", lblSample.FontUnderline)
.Color = GetSetting(App.EXEName, "Option", _
"ForeColor", lblSample.ForeColor)
.ShowFont
lblSample.Font.Charset = 204
lblSample.FontBold = .FontBold
lblSample.FontItalic = .FontItalic
lblSample.FontName = .FontName
lblSample.FontSize = .FontSize
lblSample.FontStrikethru = .FontStrikethru
lblSample.FontUnderline = .FontUnderline
lblSample.ForeColor = .Color
End With
End Select
Exit Sub



LocalErr:

Select Case Err.Number

Case 32755 'пользователь нажал отмену
Case Else
MsgBox Err.Number & " - " & Err.Description
End Select
Exit Sub
End Sub

Для меню кнопки текст используется InputBox для получения данных от пользователя. И обязательно проводится проверка на пустую строку.

Private Sub mnuText1_Click(Index As Integer)
Dim strInput As String
Select Case Index
Case 0 'добавить
strInput = InputBox("Введите 'умную мысль':", "Добавить")
'если пользователь ничего не ввел
If strInput = vbNullString Then Exit Sub
lstText.AddItem strInput

Case 1 'редактировать
If lstText.ListIndex = -1 Then
MsgBox "Не выбран текст для редактирования", _
vbInformation + vbOKOnly, "Ошибка!"
Exit Sub
End If
strInput = InputBox("Отредактируйте 'умную мысль':", _
"Редактирование", lstText.List(lstText.ListIndex))
'если пользователь ничего не ввел
If strInput = vbNullString Then Exit Sub
lstText.RemoveItem lstText.ListIndex
lstText.AddItem strInput

Case 2 'удалить
If lstText.ListIndex = -1 Then
MsgBox "Не выбран текст для удаления", _
vbInformation + vbOKOnly, "Ошибка!"
Exit Sub
End If

If MsgBox("Вы действительно хотите удалить данную запись?", _
vbYesNo + vbDefaultButton2 + vbQuestion, "Удаление") = vbYes Then
lstText.RemoveItem lstText.ListIndex
End If
End Select
End Sub



Шаг 10. Вернемся к кнопке ОК. Теперь самое время сохранять в реестре произведенные пользователем изменения. Все данные о шрифте и цвете берутся с лейбла предварительного просмотра. А вот тексты "умных мыслей" сохраняются в другой секции ("Texts"), причем вначале из этой секции все удаляется, а затем заново записываются строки из списка. После всего этого выгружаем форму.

Private Sub cmdOK_Click()
Dim i As Integer
'Сохраняем настройки
SaveSetting App.EXEName, "Option", "FontCharset", 204
SaveSetting App.EXEName, "Option", "FontBold", lblSample.FontBold
SaveSetting App.EXEName, "Option", "FontItalic", lblSample.FontItalic
SaveSetting App.EXEName, "Option", "FontName", lblSample.FontName
SaveSetting App.EXEName, "Option", "FontSize", lblSample.FontSize
SaveSetting App.EXEName, "Option", "FontStrikethru", _
lblSample.FontStrikethru
SaveSetting App.EXEName, "Option", "FontUnderline", _
lblSample.FontUnderline
SaveSetting App.EXEName, "Option", "ForeColor", lblSample.ForeColor
SaveSetting App.EXEName, "Option", "BackColor", lblSample.BackColor
If optMove(0).Value = True Then
i = 0
Else
i = 1
End If
SaveSetting App.EXEName, "Option", "Move", i
On Error Resume Next
DeleteSetting App.EXEName, "Texts"
For i = 0 To lstText.ListCount - 1
SaveSetting App.EXEName, "Texts", "T" & i, lstText.List(i)
Next
Unload Me
End Sub



Шаг 11. Ну и чтобы совсем распрощаться с формой настроек, сделаем маленькую "красивость". Тексты могут быть самыми разнообразными по длине, но элемент управления ListBox не поддерживает переноса строк. Как прочитать что же там написано? Воспользуемся еще одной API-функцией (ее мы так же объявим в разделе деклараций).

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Const LB_ITEMFROMPOINT = &H1A9

Выведем в событии MouseMove списка в ToolTipText всю строку списка.

NB! API-функция работает с пикселами, а не твипами. Поэтому необходимо преобразование через VB-функции Screen.TwipsPerPixelX и Screen.TwipsPerPixelY.



Private Sub lstText_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngX As Long
Dim lngY As Long
Dim lngIndex As Long
If Button = 0 Then ' если ни одна кнопка не была нажата
lngX = CLng(X / Screen.TwipsPerPixelX)
lngY = CLng(Y / Screen.TwipsPerPixelY)
With lstText
' Выбирает элемент списка
lngIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, _
ByVal ((lngY * 65536) + lngX))
' Выводит новую подсказку или стирает старую
If (lngIndex >= 0) And (lngIndex <= .ListCount) Then
.ToolTipText = .List(lngIndex)
Else
.ToolTipText = ""
End If
End With
End If
End Sub



Вот теперь форму настроек можно закрыть и перейти в основную форму для завершения кода программы.



Шаг 12. Сначала напишем процедуру TypeMove, которая определяет позиционирование выводимого текста по вертикали, в зависимости от того, что выбирал пользователь (и сохранил в реестре). А так же случайный выбор строки, которая будет выводиться на экран. Обработка ошибок здесь предназначена для того чтобы при отсутствии текста выводилось на экран хоть что нибудь.

Private Sub TypeMove()
Dim txtSetting As Variant
Dim i As Integer
On Error GoTo LocalErr
txtSetting = GetAllSettings(App.EXEName, "Texts")
i = Int((UBound(txtSetting, 1) + 1) * Rnd)
txtRunString = GetSetting(App.EXEName, "Texts", "T" & i, _
"Посетите сайт ""Visual Basic Streets""")
Select Case GetSetting(App.EXEName, "Option", "Move", 0)
Case 0 'по центру
lngPosY = (ScaleHeight - TextHeight(txtRunString)) / 2
Case 1 'случайно
lngPosY = Int((ScaleHeight - TextHeight(txtRunString) + 1) * Rnd)
End Select
lngPosX = ScaleWidth
Exit Sub

LocalErr:
txtRunString = "Посетите сайт ""Visual Basic Streets"""
Resume Next
End Sub





Шаг 13. Ну и, наконец, поправки и дополнения в Form_Load. Вначале считаем все данные из реестра, относительно шрифта и цвета. Затем запустим генератор случайных чисел (он потребуется для выбора случайной строки и позиционирования строки по высоте при соответствующей опции). Укажем начальное положение текста строки (за правым краем экрана).

...

FontBold = GetSetting(App.EXEName, "Option", "FontBold", False)
FontItalic = GetSetting(App.EXEName, "Option", "FontItalic", False)
FontName = GetSetting(App.EXEName, "Option", "FontName", "Verdana, Arial Cyr")
FontSize = GetSetting(App.EXEName, "Option", "FontSize", 8)
FontStrikethru = GetSetting(App.EXEName, "Option", _
"FontStrikethru", False)
FontUnderline = GetSetting(App.EXEName, "Option", "FontUnderline", False)
ForeColor = GetSetting(App.EXEName, "Option", "ForeColor", &HFF00FF)
BackColor = GetSetting(App.EXEName, "Option", "BackColor", 0)
Font.Charset = GetSetting(App.EXEName, "Option", "FontCharset", 204)
Randomize
lngPosX = ScaleWidth
...

В теле процедуры закомментируем изменение фона на черный цвет (он у нас определяется теперь из реестра). И не забудем включить и выключить таймер, заведующий движением строки

...

Case "/S"
Show
'BackColor = vbBlack
X = ShowCursor(False)
tmrRunString.Enabled = True
Do
DoEvents
Loop Until QuitFlag = True
X = ShowCursor(True)
tmrRunString.Enabled = False
tmrExit.Enabled = True
...



Число 13 (13 шагов) – достаточно симпатичное. Поэтому мы на нем остановимся. Скомпилируем проект. Скопируем его в директорию \\… Windows\System. И теперь можно запустить проект непосредственно из окна Свойств экрана.