Для каждого программного языка существует своя ниша, в том числе и для VB. Появившись на свет, как средство для обучения студентов основам программирования, Visual Basic давно уже перешагнул из своих "коротких штанишек" в разряд полноценных языков. И продолжает развиваться. Что может VB? Да очень многое. И разработчики пытаются научить его делать все больше и больше.
Эта статья написана для тех, кто только начинает осваивать VB. Поэтому я постараюсь показать в ней различные подходы и уловки, которые не всегда можно найти в справочной литературе. А так же и некоторые недоработки языка и как их обходить.
С чем познакомимся в этой статье:
-
естественно, с созданием защитника экрана
-
работой с некоторыми API-функциями
-
как работать с реестром стандартными VB-методами
-
как работать со шрифтами через элемент управления
CommonDialog
-
как создать нестандартный элемент управления (кнопка с выпадающим меню)
Разделим всю работу на две части. В первой мы создадим "болванку", на основе которой, в дальнейшем можно будет создавать свои защитники. А во второй, создадим простой защитник "Бегущая строка", отличающийся от стандартного, тем, что выполняться будет не одна запись, а несколько. И назовем мы его скромно –
CleverThoughts ("умные мысли") :)
Часть первая.
Шаг 1. Создайте новый проект Standard EXE. Не откладывая дела в долгий ящик, зайдем в свойства проекта: меню Project/Project1 Properties… В открывшемся диалоговом окне заполним данные:
Project Name = CleverThoughts
Project Description = "Screen saver"
И самое главное! Title = "SCRNSAVE:CleverThoughts"
Нажмите кнопку ОК.
NB! Слово "SCRNSAVE", отделенное от названия двоеточием (без пробелов!), необходимо будет окну "Свойства", откуда запускается защитник.
Далее изменим некоторые свойства формы:
Name=frmSsaver
ControlBox=False
BorderStyle=0 (None)
Font=любой
ForeColor=&H00FF00FF&
WindowState=2 (Maximized)
NB! Установка свойства ForeColor в розовый цвет необходима только на начальном этапе. По своему желанию вы можете ее изменить на любой другой, хорошо видный на черном фоне.
Сохраним проект. Далее (будьте внимательны!), делаем первую компиляцию файла. Меню File/Make CleverThoughts.exe ... В диалоговом окне сохранения файлов изменим расширение файла с EXE на SCR, т.к. защитники экрана носят именно такое расширение.
NB! В дальнейшем, сохраняя промежуточные версии защитника, Вы уже увидите меню File/Make CleverThoughts.scr ...
Шаг 2. Разместим на форме таймер, отвечающий (кроме всех прочих ухищрений) за закрытие приложения.
Name=tmrExit
Enabled=False
Interval=1
NB! Не смотря на то, что интервал позволяет устанавливать такие параметры, как 1, реально точность Timer начинается приблизительно с 18-20 (т.е. 0,02 сек).
Объявим декларации и константы API-функций. Первая функция отвечает за информирование системы, что защитник экрана на данный момент является активным.
Private Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Const SPI_SETSCREENSAVEACTIVE = 17
Вторая – руководит скрытием и показом курсора.
Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long
Шаг 3. Сейчас займемся событиями, в которых отслеживается, что защитник экрана пора выгружать. По логике самого защитника он должен выгружаться, если:
- Произведен щелчок мыши по форме – событие Form_Click
- Нажата любая клавиша – событие Form_KeyDown
- Изменено положение курсора (сдвинута мышь) – событие Form_MouseMove
- Как подстраховка, включился таймер – событие tmrExit_Timer
В раздел деклараций добавим переменную, сигнализирующую о необходимости закрытия защитника.
Dim QuitFlag As Boolean
События Form_Click и Form_KeyDown не сложны. Они только командуют изменением булевой переменной, и состоят всего из одной строки:
QuitFlag = True
Событие таймера – не сложнее. Оно просто командует выгрузкой формы.
Unload Me
А вот событие Form_MouseMove, чуть-чуть посложнее. Оно должно действительно убедиться, что мышь была сдвинута:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single) Static Xlast, Ylast Dim Xnow Dim Ynow
'Получение текущей позиции
Xnow = X Ynow = Y
'При первом перемещении, просто производится запись текущей позиции
If Xlast = 0 And Ylast = 0 Then
Xlast = Xnow Ylast = Ynow
Exit Sub
End If
'Выход, если мышь действительно изменила свою позицию
If Xnow <> Xlast Or Ynow <> Ylast Then
QuitFlag = True
End If
End Sub
Ну и, наконец, событие Form_Unload, в котором происходит сообщение системе, что защитник неактивен.
Private Sub Form_Unload(Cancel As Integer)
Dim X
X = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, ByVal 0&,
0)
End Sub
Шаг 4. Самый важный. Обработаем событие Form_Load. Именно здесь определяется, как загружено наше приложение: в режиме просмотра или работы, запущен пароль или открыто окно настроек. Приложение "Свойства экрана" запрашивает это командной строкой. Поэтому и обработку мы должны выполнять, подразумевая, что оно запросило.
Но перед этим мы должны вначале послать сигнал системе, что приложение активно, т.е. еще раз использовать ту же API-функцию.
Private Sub Form_Load()
Dim X
X = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, ByVal 0&, 0)...
Теперь займемся командной строкой. "Свойства экрана" используют следующие буквы для определения активности защитника экрана:
1. Р - просмотр
2. С - настройки
3. А - пароль
4. S - работа
Используем функцию Select … Case для отслеживания запроса:
Select Case UCase$(Left$(Command$, 2))
Case "/P"
'Обычная выгрузка после завершения просмотра
Unload Me
Exit Sub
Case "/C"
'Загрузка окна настроек (ее мы создадим чуть позже)
frmSSetup.Show vbModal
'Выгрузка всего приложения после изменения настроек
Unload Me
Exit Sub
Case "/A"
'Мы не будем создавать паролирование данного защитника,
'так как разбор вопросов кодирования и раскодирования
'слишком велик и должен представлять отдельную статью.
'Для желающих все-таки заняться паролированием: необходимо
'создать для этого отдельную форму или использовать InputBox,
'которые будут запускаться отсюда
MsgBox "Данный защитник не предусмотрен для паролей"
'Выгрузка всего приложения после изменения пароля
Unload Me
Exit Sub
Case "/S"
'Запускаем приложение Show
'Следующая строка временная, в дальнейшем фон будет
'определяться из настроек
BackColor = vbBlack
'Скрываем курсор
X =
ShowCursor(False)
'Зацикливаем процесс, до момента изменения флага
Do
DoEvents
Loop Until QuitFlag = True
'Если мы вышли из цикла, значит, приложение завершило свою
'работу. Мы показываем курсор и включаем таймер выхода из
'программы
X = ShowCursor(True) tmrExit.Enabled = True
'Во всех остальных случаях – просто выгружаем приложение
Case Else
Unload Me
Exit Sub
End Select
NB! API-функция, скрывающая курсор, скрывает только его изображение. Поэтому событие MouseMove все равно будет работать.
Шаг 5. Займемся окном для настроек. Выберем меню Project/Add Form …, и в диалоговом окне выберем обычную форму. Изменим некоторые ее параметры:
Name=frmSSetup
BorderStyle=3 (Fixel Dialog)
Caption=Настройки
StartupPosition=2 (CenterScreen)
Добавим две кнопки. Первая:
Name=cmdOK
Default=True
Caption=ОК
И вторая:
Name=cmdCancel
Cancel=True
Caption=Отмена
Для каждой из кнопок введем код (в дальнейшем для кнопки ОК мы его расширим):
Unload Me
На этом создание "болванки" для защитника экрана можно считать законченным. Скомпилируйте промежуточную версию проекта.
Лирическое отступление 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", "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 "Посетите сайт ""Азбука Visual
Basic"""
End Sub
NB! Первой строкой идет сохранение кодировки. К моему сожалению, я не нашел у данного контрола свойства, сохраняющего кодировку шрифта. Кириллица = 204.
Лирическое отступление 2. Немного подробнее о функции GetAllSettings. Вначале считываем в переменную все содержание указанной секции. Переменная должна быть Variant, так как она содержит массив данных. В нашем случае если мы попросим переменную показать данные с параметрами txtSetting(1,0) – то увидим НАЗВАНИЕ первого параметра ("Т0"). А если с параметрами txtSetting(1,1) – то ЗНАЧЕНИЕ этого же параметра ("Посетите сайт "Азбука Visual Basic""). Как рекомендация, перед работой с данной функцией сделайте обработку ошибок на случай отсутствия записей.
Шаг 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 LongPrivate
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
im 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, "Посетите сайт ""Mik-Seite""")
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 = "Посетите сайт ""Mik-Seite"""
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", "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. И теперь можно запустить проект непосредственно из окна Свойств экрана.
Полный листинг программы
Форма frmSsaver
Option Explicit
'Declare API информирующая систему, что screen saver активный
Private Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
ByVal lpvParam As Any, _
ByVal fuWinIni As Long) _
As Long
'Declare API скрытия и показа курсора
Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) _
As Long
'Declare Constants
Const SPI_SETSCREENSAVEACTIVE = 17
Dim QuitFlag As Boolean
Dim lngPosX As Long
Dim lngPosY As Long
Dim txtRunString As String
Private Sub Form_Click()
QuitFlag = True
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
QuitFlag = True
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static Xlast, Ylast
Dim Xnow
Dim Ynow
Xnow = X
Ynow = Y
If Xlast = 0 And Ylast = 0 Then
Xlast = Xnow
Ylast = Ynow
Exit Sub
End If
If Xnow <> Xlast Or Ynow <> Ylast Then
QuitFlag = True
End If
End Sub
Private Sub tmrExit_Timer()
Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim X
X = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, ByVal 0&, 0)
End Sub
Private Sub Form_Load()
Dim X
FontBold = GetSetting(App.EXEName, "Option", "FontBold", False)
FontItalic = GetSetting(App.EXEName, "Option", "FontItalic", False)
FontName = GetSetting(App.EXEName, "Option", "FontName", "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
X = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, ByVal 0&, 0)
Select Case UCase$(Left$(Command$, 2))
Case "/P"
Unload Me
Exit Sub
Case "/C"
frmSSetup.Show vbModal
Unload Me
Exit Sub
Case "/A"
MsgBox "No password for this screen saver"
Unload Me
Exit Sub
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
Case Else
Unload Me
Exit Sub
End Select
End Sub
Private Sub tmrRunString_Timer()
Cls
lngPosX = lngPosX - 50
If lngPosX <= -TextWidth(txtRunString) Then
TypeMove
End If
CurrentX = lngPosX
CurrentY = lngPosY
Print txtRunString
End Sub
Private Sub TypeMove()
Dim txtSetting As Variant
Dim i%
On Error GoTo LocalErr
txtSetting = GetAllSettings(App.EXEName, "Texts")
i = Int((UBound(txtSetting, 1) + 1) * Rnd)
txtRunString = GetSetting(App.EXEName, "Texts", "T" & i, "Посетите сайт
""Mik-Seite""")
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 = "Посетите сайт
""Mik-Seite"""
Resume Next
End Sub
Форма frmSSetup
Option Explicit
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
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
Dim i%
'Сохраняем настройки
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
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
Private Sub Form_Load()
Dim i%
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", "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 "Посетите сайт ""Mik-Seite"""
End Sub
Private Sub lstText_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lXPoint As Long
Dim lYPoint As Long
Dim lIndex As Long
If Button = 0 Then ' если ни одна кнопка не была нажата
lXPoint = CLng(X / Screen.TwipsPerPixelX)
lYPoint = CLng(Y / Screen.TwipsPerPixelY)
With lstText
' Выбирает элемент списка
lIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, ByVal ((lYPoint * 65536) + lXPoint))
' Выводит новую подсказку или стирает старую
If (lIndex >= 0) And (lIndex <= .ListCount) Then
.ToolTipText = .List(lIndex)
Else
.ToolTipText = ""
End If
End With
End If
End Sub
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
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