Found reason why it netmaestros code did not work (on all notebooks I have checked the program):
It's the resize command - when it is in the code, the screen stays black here... (see also thread
http://www.purebasic.fr/english/viewtop ... 880#153880)
Now this is my "working" code - what means it really can cross fade (on some notebooks, not on mine

).

therefore, also a fade out/in mode is implemented, this works also on my notebook

this mode is default, it can be changed by pressing 'M'

if anyone find, what could be changed, that cross fade will also work on my notebook, this would be great...
:roll: other improvements are also welcome...
Other keys:

+/-: speed up/down fading time

f/s: faster/slower dia show (decrease/increase delay between pictures)

i: show information (and parameter values

)

space: next picture

Escape: quit
Attention:

Please change the scanpath variable to your picture directory

You should also play around with the FrameX/Y values

Don't change the copyright line with my name
Code: Select all
; Define
#MaxNames=10000
Global ScreenX=GetSystemMetrics_(#SM_CXSCREEN)
Global ScreenY=GetSystemMetrics_(#SM_CYSCREEN)
Global FrameSizeX=ScreenX*0.8;640
Global FrameSizeY=ScreenY*0.9;540
Structure PictStruct
id.l
x.l
y.l
w.l
h.l
nr.l
EndStructure
Global Dim Picture.PictStruct(2)
Global Dim Names.s(#MaxNames)
Global MainPict=1
Global BackPict
Global TotalPict
Global ActualPict
Global WaitTimer
Global quit
#WaitDefault=5000
Global VarWait=#WaitDefault
Global VarSpeed=5; 3; 5; 15; 17
Global VarMode=1
Global VarInfo=1
DataSection
SpeedTable:
Data.l 6,3,5,15,17,45,85
WaitTable:
Data.l 8,500,1000,2000,3000,5000,10000,20000,30000
EndDataSection
; EndDefine
Procedure Directory(depth,path.s)
If ExamineDirectory(depth,path,"*.*")
While NextDirectoryEntry(depth)
Protected FileName.s = DirectoryEntryName(depth)
If DirectoryEntryType(depth)=2
If FileName<>"." And FileName<>".."
Directory(depth+1,path+FileName+"\")
EndIf
Else
If FindString("|.jpg|.bmp|",LCase(Right(FileName,4)),1) ;|.png|.gif|.tif| ???
TotalPict+1
Names(TotalPict)=path+FileName
EndIf
EndIf
Wend
FinishDirectory(depth)
EndIf
EndProcedure
Procedure.l FindVal(mem,val)
Protected i=0
Protected n=PeekL(mem)
Protected x
Repeat
i+1
mem+4
x=PeekL(mem)
If x=val
ProcedureReturn i
EndIf
Until i=n
ProcedureReturn -1
EndProcedure
Procedure.l TakeVal(mem,nr)
If nr<1
nr=1
ElseIf nr>PeekL(mem)
nr=PeekL(mem)
EndIf
ProcedureReturn PeekL(mem+nr<<2)
EndProcedure
Procedure Scale(nr)
Protected skalierung.f
If IsImage(nr)=0
CreateImage(nr,32,32,#PB_Image_DisplayFormat)
EndIf
Picture(nr)\w=ImageWidth(nr)
Picture(nr)\h=ImageHeight(nr)
If Picture(nr)\w>FrameSizeX
skalierung=FrameSizeX/Picture(nr)\w
Picture(nr)\w*skalierung
Picture(nr)\h*skalierung
EndIf
If Picture(nr)\h>FrameSizeY
skalierung.f=FrameSizeY/Picture(nr)\h
Picture(nr)\w*skalierung
Picture(nr)\h*skalierung
EndIf
Picture(nr)\id=ImageID(nr)
Picture(nr)\x=(ScreenX-Picture(nr)\w)>>1
Picture(nr)\y=(ScreenY-Picture(nr)\h)>>1
;ResizeImage(nr,Picture(nr)\w,Picture(nr)\h,#PB_Image_Smooth)
If IsSprite(nr) : FreeSprite(nr) : EndIf
CreateSprite(nr,Picture(nr)\w,Picture(nr)\h,#PB_Sprite_Texture)
StartDrawing(SpriteOutput(nr))
DrawImage(Picture(nr)\id,0,0,Picture(nr)\w,Picture(nr)\h); because Resize doesn't work
StopDrawing()
If IsSprite3D(nr) : FreeSprite3D(nr) : EndIf
CreateSprite3D(nr,nr)
EndProcedure
Procedure SwapPictures()
BackPict=MainPict
MainPict=3-MainPict
If IsImage(MainPict)
FreeImage(MainPict)
If ActualPict<TotalPict
ActualPict+1
Else
ActualPict=1
EndIf
Picture(MainPict)\nr=ActualPict
;Debug Names(ActualPict)
LoadImage(MainPict,Names(ActualPict),#PB_Image_DisplayFormat)
Scale(MainPict)
EndIf
EndProcedure
Procedure CheckKeys()
Repeat
count+1
If WaitWindowEvent(5)=#WM_CHAR
Select EventwParam()
Case 27,8,'Q'
quit=999
Case ' ',13
quit=1
Case '+'
VarSpeed=TakeVal(?SpeedTable,FindVal(?SpeedTable,VarSpeed)+1)
Case '-'
VarSpeed=TakeVal(?SpeedTable,FindVal(?SpeedTable,VarSpeed)-1)
Case 'f','F'; Faster
VarWait=TakeVal(?WaitTable,FindVal(?WaitTable,VarWait)-1)
quit=1
Case 's','S'; Slower
VarWait=TakeVal(?WaitTable,FindVal(?WaitTable,VarWait)+1)
Case 'd','D'; Default
VarWait=#WaitDefault
Case 'i','I','?'; Info
VarInfo=1-VarInfo
quit=1
Case 'm','M'; Mode
VarMode=1-VarMode
Case 'r','R'; Restart
ActualPict=0
quit=1
EndSelect
EndIf
Until (quit) Or (GetTickCount_()>WaitTimer)
EndProcedure
Procedure Show()
If (InitSprite() And InitSprite3D() And OpenScreen(ScreenX,ScreenY,32,"Show me a bird..."))
LoadFont(0,"Verdana",8)
CreateSprite(0,16,16,#PB_Sprite_Texture)
;TransparentSpriteColor(Spr,$80808)
StartDrawing(SpriteOutput(0))
Box(0,0,16,16,$20202)
StopDrawing()
CreateSprite3D(0,0)
ZoomSprite3D(0,ScreenX,ScreenY)
Scale(1)
Scale(2)
Repeat
quit=0
check+1
SwapPictures()
i=0
Repeat
WaitTimer=GetTickCount_()+50
If VarMode
Start3D()
DisplaySprite3D(0,0,0,255)
Stop3D()
If i<128
DisplaySprite(BackPict,Picture(BackPict)\x,Picture(BackPict)\y)
Start3D()
DisplaySprite3D(0,0,0,i<<1)
Stop3D()
Else
DisplaySprite(MainPict,Picture(MainPict)\x,Picture(MainPict)\y)
Start3D()
DisplaySprite3D(0,0,0,511-i<<1)
Stop3D()
EndIf
Else
Start3D()
DisplaySprite3D(0,0,0,255)
DisplaySprite3D(BackPict,Picture(BackPict)\x,Picture(BackPict)\y,255-i)
DisplaySprite3D(MainPict,Picture(MainPict)\x,Picture(MainPict)\y,i)
Stop3D()
EndIf
If VarInfo
StartDrawing(ScreenOutput())
DrawingFont(FontID(0))
DrawText(10,10,Names(ActualPict),#Green,#Black)
DrawText(10,ScreenY-14,"©2006 Michael Vogel • V"+Str(VarSpeed)+"."+Str(VarWait)+Str(VarMode),#Green,#Black)
StopDrawing()
EndIf
FlipBuffers()
CheckKeys()
;If quit : Break : EndIf
i+VarSpeed
Until i>255
If quit=0
WaitTimer=GetTickCount_()+VarWait
CheckKeys()
EndIf
Until quit>1
EndIf
FreeFont(0)
;MessageRequester(Str(count),"-"
EndProcedure
Procedure Main()
scanpath.s="F:\Programs\Prog\Source\Fade\"
Directory(0,scanpath)
UseJPEGImageDecoder()
;UsePNGImageDecoder(); 80kByte !
If TotalPict : Show() : EndIf
EndProcedure
Main()