PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

PureBasic Screensaver mit Ein- und Ausblendeffekt

https://www.purebasic.fr/german/viewtopic.php?t=16054

Seite 1 von 1

PureBasic Screensaver mit Ein- und Ausblendeffekt

Verfasst: 17.03.2008 22:35
von legion
Hallo !

Hab mal einen Screensaver probiert.

Zu erst eine EXE erstellen und dann die Endung auf SCR umbenennen.
Mit rechter Maustaste anklicken --> installieren oder nach Windows\System32 kopieren
Getestet unter Windows XP SP2 und Windows Vista

Download:PBScreensaver.zip

Lg. Legion

Code: Alles auswählen

Global XPOS.l,YPOS.l
Global EXITSTATUS.b
Global FirstParam.s,Command.s
;-----------------------------------------------------------------------------------------------------------
Procedure PreviewAutoDestruction(window,message,wParam,lParam) 
 Shared WM_DestroyPreview    
 Result = #PB_ProcessPureBasicEvents 
 Select message 
  Case #WM_CLOSE 
   DestroyWindow_(window)
   If IsImage(1): FreeImage(1) : EndIf 
   End 
  Case WM_DestroyPreview 
   If IsImage(1): FreeImage(1) : EndIf
   End 
  EndSelect 
 ProcedureReturn Result 
EndProcedure 
;-----------------------------------------------------------------------------------------------------------
Procedure Preview(preview) 
 CatchImage(1,?VOS)
 UseGadgetList(preview) 
 GetClientRect_(preview,@rc.rect)    
 ImageGadget(1,0,0,0,0,ImageID(1))  
 CloseGadgetList() 
 Shared WM_DestroyPreview 
 WM_DestroyPreview=RegisterWindowMessage_(@"PREVIEW AUTO DESTRUCTION") 
 SendMessage_(#HWND_BROADCAST,WM_DestroyPreview,0,0)          
 SetParent_(OpenWindow(0,0,0,0,0,"CHILD WINDOW",#PB_Window_Invisible),preview)    
 SetWindowCallback(@PreviewAutoDestruction())    
 Repeat 
  WaitWindowEvent() 
 ForEver    
EndProcedure 
;-----------------------------------------------------------------------------------------------------------
Procedure Fadein()
 Protected i
 For i = 0 To 255 Step 5
 ClearScreen(0)
 DisplayTranslucentSprite(1,XPOS,YPOS,i)
 FlipBuffers()
 If EXITSTATUS = 1 : Break : EndIf
 Next i 
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure Fadeaut()
 Protected i = 255
 While i > 1
 ClearScreen(0)
 DisplayTranslucentSprite(1,XPOS,YPOS,i)
 FlipBuffers()
 i = i-5
 If EXITSTATUS = 1 : Break : EndIf
 Wend
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure RandomPos(index)
 Repeat
 XPOS = Random(DesktopWidth(0)-ImageWidth(0))
 YPOS = Random(DesktopHeight(0)-ImageHeight(0))
 If EXITSTATUS = 1 : Break : EndIf
 StartSpecialFX()
 Fadein()
 StopSpecialFX()
 If EXITSTATUS = 1 : Break : EndIf
 Delay(4000)
 If EXITSTATUS = 1 : Break : EndIf
 StartSpecialFX()
 Fadeaut()
 StopSpecialFX()
 If EXITSTATUS = 1 : Break : EndIf
 ForEver
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure Main()
  If InitSprite() And InitSound() And InitKeyboard() And ExamineDesktops() And InitMouse()And OpenScreen(DesktopWidth(0),DesktopHeight(0),DesktopDepth(0),"")
  CatchImage(0,?BAK)
  CatchSprite(1,?BAK,#PB_Sprite_Memory)
  StartSpecialFX()
  Thread = CreateThread(@RandomPos(),0)
   If IsThread(Thread)
   Repeat  
    ExamineMouse()
    MouseDeltaX()
    MouseDeltaY()
    If MouseDeltaX() <> 0 Or MouseDeltaY() <> 0
     EXITSTATUS = 1
     WaitThread(Thread)
     Break 
    EndIf
    Delay(1)
   ForEver
 EndIf
 FreeImage(0)
 FreeSprite(1) 
 Else
  MessageRequester("Fehler","Konnte DirectX nicht einwandfrei initialisieren",#PB_MessageRequester_Ok)
 EndIf 
EndProcedure
;-----------------------------------------------------------------------------------------------------------
 FirstParam      = ProgramParameter() 
 Command         = LCase(Left(ReplaceString(FirstParam,"-","/"),2))
 ParentWindow.l  = Val(StringField(FirstParam,2,":")) | Val(ProgramParameter())
 EXITSTATUS      = 0
;----------------------------------------------------------------------------------------------------------- 
 Select Command      
 Case "/p" 
  ;Preview
  Preview(ParentWindow) 
;-----------------------------------------------------------------------------------------------------------
 Case "/c" 
  ;Config
  MessageRequester("Info","Dieser Bildschirmschoner hat keine Optionen, die Sie einstellen können",#PB_MessageRequester_Ok)      
;-----------------------------------------------------------------------------------------------------------
 Default 
  ;Start Screensaver
  Main()
EndSelect 
;-----------------------------------------------------------------------------------------------------------
End
;-----------------------------------------------------------------------------------------------------------
;Nicht vergessen auf eigene Pfade umzustellen ! ! ! ! ! ! ! ! 
DataSection
BAK: IncludeBinary "Logo das eingeblendet wird"
VOS: IncludeBinary "Vorschaubild"
EndDataSection

Verfasst: 22.03.2008 18:58
von legion
#EDIT
Hier noch eine andere Version mit AlphaBlend ohne Sprites und ohne Direct-X.

Code: Alles auswählen

Prototype AlphaBlend(DestDC,x1,y1,w1,h1,SourceDC,x2,y2,w2,h2,BF)
Msimg32 = OpenLibrary(#PB_Any, "msimg32.dll")
If Msimg32
 Global AlphaBlend_.AlphaBlend = GetFunction(msimg32, "AlphaBlend")
Else
 MessageRequester("Fehler!","Kann msimg32.dll nicht öffnen !",#MB_ICONERROR)
 Goto EXIT
EndIf  
;-----------------------------------------------------------------------------------------------------------
#AC_SRC_OVER  = 0  ;Die Quelle wird über dem Ziel gezeichnet
#AC_SRC_ALPHA = 1  ;Das Quellbitmap enthält bereits einen Alphawert
;-----------------------------------------------------------------------------------------------------------
Enumeration
  #Window_0
EndEnumeration
;-----------------------------------------------------------------------------------------------------------
Enumeration
  #Image_0
  #Image_1
  #Image_2
EndEnumeration
;-----------------------------------------------------------------------------------------------------------
Global XPOS.l,YPOS.l
Global EXITSTATUS.b
Global FirstParam.s,Command.s
Global *AlphaBlend.l,Kanal.b
;-----------------------------------------------------------------------------------------------------------
Procedure PreviewAutoDestruction(window,message,wParam,lParam) 
 Shared WM_DestroyPreview    
 Result = #PB_ProcessPureBasicEvents 
 Select message 
  Case #WM_CLOSE 
   DestroyWindow_(window)
   If IsImage(1): FreeImage(1) : EndIf 
   End 
  Case WM_DestroyPreview 
   If IsImage(1): FreeImage(1) : EndIf
   End 
  EndSelect 
 ProcedureReturn Result 
EndProcedure 
;-----------------------------------------------------------------------------------------------------------
Procedure Preview(preview) 
 UseGadgetList(preview) 
 GetClientRect_(preview,@rc.rect)    
 ImageGadget(1,0,0,0,0,ImageID(1))  
 CloseGadgetList() 
 Shared WM_DestroyPreview 
 WM_DestroyPreview=RegisterWindowMessage_(@"PREVIEW AUTO DESTRUCTION") 
 SendMessage_(#HWND_BROADCAST,WM_DestroyPreview,0,0)          
 SetParent_(OpenWindow(0,0,0,0,0,"CHILD WINDOW",#PB_Window_Invisible),preview)    
 SetWindowCallback(@PreviewAutoDestruction())    
 Repeat 
  WaitWindowEvent() 
 ForEver    
EndProcedure 
;-----------------------------------------------------------------------------------------------------------
Procedure BlendImages(Image1,Image2,AlphaWert,AlphaFormat)
 Protected BackImageID,NewImageHDC,BF,*BF.BLENDFUNCTION = @BF  
  *BF\BlendOp = #AC_SRC_OVER
  *BF\BlendFlags = 0
  *BF\SourceConstantAlpha = AlphaWert
  *BF\AlphaFormat = AlphaFormat
  WinHDC = GetDC_(WindowID(#Window_0)) : TempDC = CreateCompatibleDC_(WinHDC) 
  BackImageID = CreateImage(#PB_Any,ImageWidth(Image1),ImageHeight(Image1)) 
  NewImageHDC = StartDrawing(ImageOutput(BackImageID))
  SelectObject_(TempDC,ImageID(Image1))
  BitBlt_(NewImageHDC,0,0,ImageWidth(Image1),ImageHeight(Image1),TempDC,0,0,#SRCCOPY)  
  SelectObject_(TempDC,ImageID(Image2))
  AlphaBlend_(NewImageHDC,0,0,ImageWidth(Image1),ImageHeight(Image1),TempDC,0,0,ImageWidth(Image2),ImageHeight(Image2),BF)  
  StopDrawing()  
  SelectObject_(TempDC,ImageID(BackImageID))
  BitBlt_(WinHDC,XPOS,YPOS,ImageWidth(Image1),ImageHeight(Image1),TempDC,0,0,#SRCCOPY)
  ReleaseDC_(WindowID(#Window_0),WinHDC) : DeleteDC_(TempDC) : FreeImage(BackImageID)
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure Fadein()
 Protected i
 For i = 0 To 255
 BlendImages(#Image_1,#Image_2,i,0)
 Delay(5)
 If EXITSTATUS = 1 : Break : EndIf
 Next i 
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure Fadeaut()
 Protected i = 255
 While i > 1
 BlendImages(#Image_1,#Image_2,i,0)
 Delay(5)
 i = i-1
 If EXITSTATUS = 1 : Break : EndIf
 Wend
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure RandomPos(index)
 Repeat
 XPOS = Random(DesktopWidth(0)-ImageWidth(#Image_2))
 YPOS = Random(DesktopHeight(0)-ImageHeight(#Image_2))
 Fadein()
 Delay(3000)
 Fadeaut()
 If EXITSTATUS = 1 : Break : EndIf
 ForEver
EndProcedure
;-----------------------------------------------------------------------------------------------------------
Procedure Main()
Protected x,y
If OpenWindow(#Window_0,0,0,DesktopWidth(DT),DesktopHeight(DT), "Demo",#PB_Window_BorderLess|#PB_Window_Maximize)
  ShowCursor_(0)
  SetWinBackgroundColor(WindowID(#Window_0),0);benötigt PBOSL_SkinWin
  StickyWindow(#Window_0,1)
  x = WindowMouseX(#Window_0)
  y = WindowMouseY(#Window_0)  
  Thread = CreateThread(@RandomPos(),0)
  If IsThread(Thread) 
   Repeat  
    Event = WaitWindowEvent()
    WindowID = EventWindow()
    GadgetID = EventGadget()
    EventType = EventType()
    
    If Event = #WM_KEYDOWN
     EXITSTATUS = 1
     WaitThread(Thread,10)
     Break     
    EndIf
    If WindowMouseX(#Window_0) <> x Or WindowMouseY(#Window_0) <> y
     EXITSTATUS = 1
     WaitThread(Thread,10)
     Break 
    EndIf
   Until Event = #PB_Event_CloseWindow
 EndIf
EndIf  
EndProcedure
;-----------------------------------------------------------------------------------------------------------
 FirstParam      = ProgramParameter() 
 Command         = LCase(Left(ReplaceString(FirstParam,"-","/"),2))
 ParentWindow.l  = Val(StringField(FirstParam,2,":")) | Val(ProgramParameter())
 EXITSTATUS      = 0
 DT              = ExamineDesktops() 
 
 CatchImage(#Image_0,?VOS)
 CatchImage(#Image_1,?BLA)
 CatchImage(#Image_2,?BAK)
;----------------------------------------------------------------------------------------------------------- 
 Select Command      
 Case "/p" 
  ;Preview
  Preview(ParentWindow) 
;-----------------------------------------------------------------------------------------------------------
 Case "/c" 
  ;Config
  MessageRequester("Info","Dieser Bildschirmschoner hat keine Optionen, die Sie einstellen können",#PB_MessageRequester_Ok)      
;-----------------------------------------------------------------------------------------------------------
 Default 
  ;Start Screensaver
  Main()
EndSelect 
;----------------------------------------------------------------------------------------------------------- 
 FreeImage(#Image_0)
 FreeImage(#Image_1)
 FreeImage(#Image_2)
EXIT: 
End
;-----------------------------------------------------------------------------------------------------------
;Nicht vergessen auf eigene Pfade umzustellen ! ! ! ! ! ! ! ! 
DataSection
BAK: IncludeBinary "Logo das eingeblendet werden soll (24Bit BMP)"
VOS: IncludeBinary "Vorschaubild für Windows 152x112 Pixel (24Bit BMP)"
BLA: IncludeBinary "Hintergrundbild schwarz mit gleicher Grösse wie Logo (24Bit BMP)"
EndDataSection

Verfasst: 22.03.2008 22:43
von SoS
legion,benutze Prototypes für die Msimg32.dll
http://www.purebasic.fr/english/viewtop ... 323#214323

Der Bug ist schon ewig bekannt.
http://www.purebasic.fr/english/viewtopic.php?t=29519

Verfasst: 23.03.2008 00:04
von legion
SoS hat geschrieben:Der Bug ist schon ewig bekannt.
http://www.purebasic.fr/english/viewtopic.php?t=29519
Da geht es doch um "TransparentBlt" und nicht um "AlphaBlend" !

Trotzdem danke für den Tipp ! :wink:

Lg. Legion
Alle Zeiten sind UTC+02:00
Seite 1 von 1

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de