| ||||||||||||||||
![]() | ||||||||||||||||
| ||||||||||||||||
![]() | ||||||||||||||||
| ||||||||||||||||
![]() |
Лирическое отступление 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", _ lang="DE" "FontStrikethru", False) lang="DE" lblSample.FontUnderline = GetSetting(App.EXEName, "Option", _ lang="DE" "FontUnderline", False) lang="DE" 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 " Посетите сайт "" Visual Basic 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, _ lang="DE" "Option", "FontStrikethru", lblSample.FontStrikethru) lang="DE" .FontUnderline = GetSetting(App.EXEName, _ lang="DE" "Option", "FontUnderline", lblSample.FontUnderline) lang="DE" .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 всю строку списка. style="COLOR: red; >NB style="COLOR: red; >! 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", _ lang="DE" "FontStrikethru", False) lang="DE" 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 . И теперь можно запустить проект непосредственно из окна Свойств экрана. [Назад] |
|
![]() | ||||||||||||||||
| ||||||||||||||||
![]() | ||||||||||||||||
|