Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Bilderanzeige / Slideshow mit FreeImage
| Uploader: |  Jojo |
| Datum/Zeit: | 23.02.2008 23:17:55 |
/'
viewer.bas version 1.0, (c) 2008 by Saga-Games; http://sagagames.de
Benötigt FreeImage, evtl auch unter Linux lauffähig. Getestet mit FB 0.18.3.
Kontinuierliche Slideshow der Bilder aus dem Verzeichnis ./images/
Automatisches Nachladen von Bildern (z.B. bei Livepräsentationen) möglich
F5 = Sofortiger Neustart der Slideshow mit Nachladen
F9 = Pause / Fortfahren
'/
#Include "freeimage.bi"
#Include "crt.bi"
#Include "file.bi"
#Include "fbgfx.bi"
Using FB
Dim Delay As Integer, FromPath As String, Fullscreen As byte
Open ExePath & "\viewer.ini" For Input As #1
Input #1, Delay
Line Input #1, FromPath
Input #1, Fullscreen
Close #1
If Right(FromPath, 1) = "\" Then FromPath = Left(FromPath, Len(FromPath) - 1)
Function GetImage(ByVal File As String, Format As Integer, FormAttrib As Integer) As Any Ptr
Dim Dib As FIBITMAP Ptr
Dim Dib32 As FIBITMAP Ptr
Dim SprWidth As Integer
Dim SprHeight As Integer
Dim Sprite As Any Ptr
Dim Bits As Any Ptr
' Bild laden:
Dib = FreeImage_Load(Format, File, FormAttrib)
If Dib = 0 Then Return 0
FreeImage_FlipVertical Dib
Dib32 = FreeImage_ConvertTo32Bits(Dib)
Dim As Integer scrX, scrY
ScreenInfo scrX, scrY
SprWidth = FreeImage_GetWidth(Dib32)
SprHeight = FreeImage_GetHeight(Dib32)
' Resize
Dim Faktor As Double
Faktor = scrX / SprWidth
If SprHeight * Faktor > scrY Then
Faktor = scrY / SprHeight
EndIf
SprWidth *= Faktor
SprHeight *= Faktor
Dib32 = FreeImage_Rescale(Dib32, SprWidth, SprHeight, FILTER_BSPLINE)
Sprite = ImageCreate(SprWidth, SprHeight)
Bits = FreeImage_GetBits(Dib32)
' Die Bilddaten kopieren...
MemCpy CPtr(ZString Ptr, Sprite) + 32, Bits, SprWidth * SprHeight * 4
' Speicher wieder freigeben
FreeImage_Unload(Dib)
FreeImage_Unload(Dib32)
DeAllocate Bits
Return Sprite
End Function
Function blender (ByVal src As UInteger, ByVal dst As UInteger, ByVal parameter As Any Ptr) As UInteger
If src = 0 Then
Dim As ubyte r = dst Shr 16, g = dst Shr 8, b = dst
Return RGB(r\2,g\2,b\2)
Else
Return dst
EndIf
End Function
Sub DrawText(sText As String)
Dim FontBuffer As Any Ptr
FontBuffer = ImageCreate(Len(sText) * 8,8)
Paint FontBuffer, (0,0), RGB(255, 0, 255)
Draw String FontBuffer, (0, 0), sText, 0
Put(2,2), FontBuffer, custom, @blender
ImageDestroy FontBuffer
End Sub
Dim As Integer w,h
If Fullscreen Then
ScreenInfo w,h
ScreenRes w,h,32,1,1
Else
w=800
h=600
ScreenRes w,h,32,1,0
EndIf
SetMouse ,,0
#define GImage_JPG(Filename) GetImage(Filename, FIF_JPEG, JPEG_DEFAULT)
Dim As String sFile = "", sNewFile, sAddStr
Dim As Double dTimer
Dim As String sKey
Dim As Byte bRefresh = 0, bExists, bPause = 0
Dim bild As Any Ptr
Dim header As Image Ptr
Do
If sFile = "" Or bRefresh = 1 Then
bRefresh = 0
If FromPath <> "" Then
' nach neuen bildern suchen
sFile = Dir(FromPath & "\*.jpg")
DrawText "refreshing file list..."
while sFile <> ""
sAddStr = ""
Do
sNewFile = Left(sFile, InStr(LCase(sFile), ".") - 1) & sAddStr & Mid(sFile, InStr(LCase(sFile), "."))
bExists = FileExists(ExePath & "\images\" & sNewFile)
sAddStr &= "_"
Loop Until bExists = 0
Name(FromPath & "\" & sFile, ExePath & "\images\" & sNewFile)
sFile = Dir()
wend
EndIf
' ...und von vorne!
sFile = Dir(ExePath & "\images\*.jpg")
EndIf
dTimer = Timer
bild = GImage_JPG(ExePath & "\images\" & sFile)
If bild Then
header = bild
Screenlock
Cls
With *header
Put(w \ 2 - .width \ 2, h \ 2 - .height \ 2), bild, PSet
End With
Screenunlock
ImageDestroy bild
DeAllocate header
End If
sFile = Dir()
Do
Sleep 10
sKey = InKey
If sKey = Chr(255, 59) Then
DrawText "esc = end \ f5 = refresh \ f9 = pause/resume"
ElseIf sKey = Chr(255, 63) And bRefresh = 0 Then
bRefresh = 1
DrawText "refreshing file list..."
ElseIf sKey = Chr(255, 67) Then
bPause = (bPause = 0)
EndIf
Loop Until sKey = Chr(27) Or (Timer > dTimer + Delay And bPause = 0)
Loop Until sKey = Chr(27)
End