You don´t need a lib.
It´s old but it´s work. I have just adapted for PB5.60
Code: Select all
;*******************************************************************
;Einfacher Bildschirmschoner, der aber alles enthaellt was ein
;Schoner so braucht. Vorschau, Passwort-Abfrage, Passwort-Aenderung
;usw.
;Ist als Grundgeruest gedacht !
;Nach dem Compilieren die EXE in SCR umbenennen !
;Andreas Miethe * Dezember 2002
;
;Angepasst 20.4.2017 von mk-soft
;
;*******************************************************************
Declare setBlack(wnd)
Declare SetPassword()
Declare ConfigSaver()
Declare VerifyPassword(wnd)
Declare CloseSaver(wnd)
Declare ExecuteSaver(wnd)
Declare PreviewCallback(Wnd, Message, wParam, lParam)
Declare Preview(wnd)
Declare WindowCallback(Wnd, Message, wParam, lParam)
Declare Main()
Global Param$,Param1$;Startparameter
Global Hwnd.i,SHwnd.i,SParanet.i;Hauptfenster,Vorschaufenster,Elternfenster(Vorschau)
Global PreviewDC.i;Devicecontext Vorschau
Global TI.i;Thread fuer Aktionen
Global Preview.i,HHDC.i;Flag,Devicecontext-Hauptfenster
Global MaxMouse.i;maximale Mausbewegung
Dim MousePos.Point(0);Mausposition-Start
Dim CurrentMousePos.Point(0);aktuelle Mausposition
#MainWindow = 1000
#PreviewWindow = 1001
Procedure SetTransparent(Window.i ,Value.i)
SetWindowLong_(Window,#GWL_EXSTYLE,GetWindowLong_(Window,#GWL_EXSTYLE) | #WS_EX_LAYERED)
SetLayeredWindowAttributes_(Window, 0, (255 * Value) / 100, #LWA_ALPHA)
EndProcedure
Procedure SetPassword()
;Password setzen
If OpenLibrary(0,"mpr.dll")
CallFunction(0 ,"PwdChangePasswordA",@"SCRSAVE",ScrWnd,0,0)
CloseLibrary(0)
EndIf
End
EndProcedure
Procedure ConfigSaver()
;Konfiguration des Schoners
MessageRequester("Screensaver","© 2002 by ampsoft"+Chr(13)+"Nichts einzurichten",64)
End
EndProcedure
Procedure VerifyPassword(wnd)
;Passwort abfragen
If (OSVersion()=#PB_OS_Windows_95) Or (OSVersion()=#PB_OS_Windows_98)Or (OSVersion()=#PB_OS_Windows_ME)
Retval = 0
hKey.i=0
If RegOpenKeyEx_(#HKEY_CURRENT_USER,"'Control Panel\desktop",0,#KEY_READ,@hKey)
;Ist Passwortschutz aktiv ?
If OpenLibrary(0,"Password.cpl")
;Abfrage
ShowCursor_(1)
Retval = CallFunction(0,"VerifyScreenSavePwd",wnd)
ShowCursor_(Retval)
CloseLibrary(0)
EndIf
RegCloseKey_(hKey)
EndIf
EndIf
ProcedureReturn Retval
EndProcedure
Procedure Main()
;Hauptfenster-Prozedur
ShowCursor_(0)
If ExamineDesktops
dx = DesktopWidth(0)
dy = DesktopHeight(0)
Else
dx = 1600
dy = 1280
EndIf
style = #PB_Window_BorderLess
If OpenWindow(#MainWindow, 0, 0, dx, dy, "Fenster", style)
StickyWindow(#MainWindow, 1)
SetWindowColor(#MainWindow, 0)
SetTransparent(WindowID(#MainWindow), 50)
SystemParametersInfo_(#SPI_SCREENSAVERRUNNING, 1, @oldval, 0)
Repeat
event = WaitWindowEvent()
window = EventWindow()
menu = EventMenu()
type = EventType()
Select event
Case #WM_LBUTTONUP
Exit = 1
Case #PB_Event_CloseWindow
Exit = 1
EndSelect
Until Exit
SystemParametersInfo_(#SPI_SCREENSAVERRUNNING, 0, @oldval, 0)
EndIf
EndProcedure
Procedure setBlack(wnd)
;schwarzer Hintergrund
R1.rect
dc = GetDC_(wnd)
Blackbrush.i = GetStockObject_(#BLACK_BRUSH)
r1\left = 0
r1\top = 0
r1\right = GetSystemMetrics_(#SM_CXSCREEN)
r1\bottom = GetSystemMetrics_(#SM_CYSCREEN)
SetBkColor_(dc,RGB(0,0,0))
FillRect_(dc,r1,blackbrush)
ReleaseDC_(wnd,dc)
EndProcedure
Procedure PreviewCallback(Wnd, Message, wParam, lParam)
;Callback fuer Vorschau
Select message
Case #WM_PAINT
setBlack(Wnd)
Case #WM_CLOSE
DeleteDC_(PreviewDC)
DeleteObject_(Hrgn)
DeleteDC_(GGDC)
KillThread(TI)
UnregisterClass_("MyScrClass",GetModuleHandle_(0))
DestroyWindow_(wnd)
End
EndSelect
Result = DefWindowProc_(wnd,message,wParam,lParam)
ProcedureReturn Result
EndProcedure
Procedure Preview(wnd)
;Vorschau-Prozedur
;Eigene Fensterklasse fuer die Vorschau anlegen
Dim ScrClass.WNDCLASS(0)
Classname$ = "MyScrClass"
ScrClass(0)\style = #CS_HREDRAW | #CS_VREDRAW
ScrClass(0)\lpfnWndProc = @PreviewCallback()
ScrClass(0)\cbClsExtra = 0
ScrClass(0)\cbWndExtra = 0
ScrClass(0)\hInstance = GetModuleHandle_(0)
ScrClass(0)\hIcon = 0
ScrClass(0)\hCursor = 0
ScrClass(0)\hbrBackground = 0
ScrClass(0)\lpszMenuName = 0
ScrClass(0)\lpszClassName = @Classname$
RegisterClass_(ScrClass(0));Fensterklasse registrieren
r.RECT
GetWindowRect_(wnd,r)
r\right = r\right - r\left
r\bottom = r\bottom - r\top
SHwnd = CreateWindowEx_(0, "MyScrClass", "",#WS_CHILD|#WS_VISIBLE, 0, 0, r\right,r\bottom, wnd, 0, GetModuleHandle_(0), 0)
If Shwnd
While GetMessage_(m.MSG,0,0,0)
TranslateMessage_(m)
DispatchMessage_(m)
Wend
EndIf
EndProcedure
;Mehrfachstart verhindern
MutextString$ = "PB-Screensaver"
MutexHandle.i = CreateMutex_(0,1,MutexString$)
If GetLastError_() = #ERROR_ALREADY_EXISTS ;Programm läuft schon
End
EndIf
;Start-Parameter aufbereiten
;Die Parameter können mit einem - oder / beginnen und zwischen erstem
;und zweitem Parameter können sich entweder ein Doppelpunkt
;oder ein Leerzeichen befinden.
;Sind sie mit einem Doppelpunkt verbunden,
;erkennt sie PB nicht als zwei Parameter,
;und speichert beide in ProgrammParameter 1
Param$ = UCase(ProgramParameter())
If Len(Param$) > 2
Param1$ = RemoveString(Param$, Left(Param$,2),1)
Else
Param1$ = ProgramParameter()
EndIf
Param$ = RemoveString(Param$, Left(Param$,1),1)
Param$ = Left(Param$,1)
Select Param$
Case ""
ConfigSaver()
Case "C"
;Einstellungen
ConfigSaver()
Case "P"
;Vorschau
Preview = 1
SParent = Val(Param1$)
PreView(SParent)
Case "A"
;Passwort
SetPassword()
Case "S"
;Hauptprogramm
Preview = 0
Main()
EndSelect