|
Option Explicit
Global Const KEYDOWNEXIT = -1
Global FIRSTTIME As Boolean
Global LASTX As Long
Global LASTY As Long
Global XPOS As Long
Global YPOS As Long
Global Preview As Boolean
Global WPPic As StdPicture
Global intOPTCounter As Integer
Type PointAPI
X As Long
Y As Long
End Type
Public MousePoint As PointAPI
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WS_CHILD = &H40000000
Private Const GWL_STYLE = (-16)
Private Const GWL_HWNDPARENT = (-8)
Private Const HWND_TOP = 0&
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Declare Function ShowCursor Lib "user32" ( _
ByVal bShow As Long) As Long
Declare Function GetCursorPos Lib "user32" ( _
lpPoint As PointAPI) As Long
Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Declare Function SetWindowPos Lib "user32" ( _
ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal _
nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetParent Lib "user32" (ByVal hWndChild _
As Long, ByVal hWndNewParent As Long) As Long
'Hauptroutine
Sub Main()
LoadSettingFile
If Left(UCase(Command), 2) = "/C" Or _
Left(UCase(Command), 2) = "-C" Then
frmOptionen.txt_Anzahl.Text = intOPTCounter
frmOptionen.Show vbModal
SaveSettingFile
Unload frmOptionen
End
End If
If App.PrevInstance Then End
If Left(UCase(Command), 2) = "/P" Or _
Left(UCase(Command), 2) = "-P" Then
Preview = True
DoPreviewMode frmSS
Set frmSS.Picture = LoadResPicture(101, vbResBitmap)
Exit Sub
End If
Set WPPic = LoadResPicture(101, vbResBitmap)
Randomize Time
HIDECURSOR
frmSS.Show
End Sub
'Mauszeiger ausschalten und alte Position sichern
Sub HIDECURSOR()
Call GetCursorPos(MousePoint)
XPOS = MousePoint.X
YPOS = MousePoint.Y
Call ShowCursor(False)
LASTX = XPOS
LASTY = YPOS
End Sub
'Tastatur- und Maus-Ereignisse auswerten
Sub MONITOREVENTS(X As Single, Y As Single)
If X = LASTX And Y = LASTY Then
Exit Sub
Else
LASTX = X
LASTY = Y
End If
If (Not FIRSTTIME) Or LASTX = KEYDOWNEXIT Then
Call ShowCursor(True)
Set WPPic = Nothing
Unload frmSS
End
Else
FIRSTTIME = False
End If
End Sub
'Bildschirmschoner-Vorschau
Sub DoPreviewMode(PreviewForm As Form)
Dim lngStyle As Long, dispHWND As Long, DispRec As RECT
dispHWND = CLng(Right(Command, Len(Command) - 3))
Load PreviewForm
GetClientRect dispHWND, DispRec
lngStyle = GetWindowLong(PreviewForm.hwnd, GWL_STYLE)
lngStyle = lngStyle Or WS_CHILD
SetWindowLong PreviewForm.hwnd, GWL_STYLE, lngStyle
SetParent PreviewForm.hwnd, dispHWND
SetWindowLong PreviewForm.hwnd, GWL_HWNDPARENT, dispHWND
SetWindowPos PreviewForm.hwnd, HWND_TOP, 0&, 0&, _
DispRec.Right, DispRec.Bottom, _
SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
End Sub
Private Sub LoadSettingFile()
Dim intFileNr As Integer
On Error GoTo ERROUT
If Dir(App.Path & "\VBFunSCR.set") <> "" Then
intFileNr = FreeFile()
Open App.Path & "\VBFunSCR.set" _
For Binary Access Read Lock Write As intFileNr
Get intFileNr, 1, intOPTCounter
Close intFileNr
Else
intOPTCounter = 20
End If
Exit Sub
ERROUT:
frmOptionen.txt_Anzahl.Text = 20
intOPTCounter = 20
End Sub
Private Sub SaveSettingFile()
Dim intFileNr As Integer
On Error GoTo ERROUT
intFileNr = FreeFile()
Open App.Path & "\VBFunSCR.set" _
For Binary Access Write Lock Read As intFileNr
Put intFileNr, 1, intOPTCounter
Close intFileNr
Exit Sub
ERROUT:
frmOptionen.txt_Anzahl.Text = 20
End Sub
|
|