Форма 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