Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Main_pre02.bas
| Uploader: |  Alexander283 |
| Datum/Zeit: | 13.12.2011 20:16:34 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts DiskMgr, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
' ##############################################################################
' # +-------+ #
' # DiskManager v pre0.2 | # | #
' # | O. | #
' # 11.12.2011 Alexander Dahmen ] | #
' # +-------+ #
' # #
' ##############################################################################
' -- Definitionen --
#define false 0
#define true not(false)
#define nul chr(0)
' ---------- Screen ------------------------------------------------------------
screen 18,32
' ---------- Typen -------------------------------------------------------------
type tdot
as integer x
as integer y
end type
type tsquare
as tdot p1
as tdot p2
end type
type tdisk
as integer x
as integer y
as integer visible
as integer grab
as string caption
as string program(255)
as tsquare button
declare sub create (buffer as any ptr,disk as tdisk,number as integer,mode as integer)
declare sub label (byref disk as tdisk,byval caption as string)
' declare sub prog (byref disk() as tdisk,byval progname() as string)
end type
type tmouse
as integer x
as integer y
as integer wheel
as integer key
as tdot button
declare sub reload(byref Mouse as tmouse)
end type
type tbox
as tsquare button
as integer result(1 to 255)
as integer returned
as integer grab
end type
' ---------- Deklarationen -----------------------------------------------------
dim Mouse as tmouse
dim Disk(1 to 255) as tdisk
dim box as tbox
dim disknumber as integer
dim grab as integer
dim key as string*1
dim i as integer
declare function inside(sqare as tsquare,dot as tdot) as integer
declare sub diskbox(disk() as tdisk,sprite as any ptr,back as any ptr)
' ---------- Sprite-Daten ------------------------------------------------------
const name_back="Background.bmp"
const name_disk="DiskBig.bmp"
const name_dbox="DiskBox.bmp"
dim ptr_back as any ptr
dim ptr_disk as any ptr
dim ptr_dbox as any ptr
ptr_back=imagecreate(640,480)
ptr_disk=imagecreate(128,128)
ptr_dbox=imagecreate(640,480)
bload name_back,ptr_back
bload name_disk,ptr_disk
bload name_dbox,ptr_dbox
' ---------- HAUPTPROGRAMM -----------------------------------------------------
for i=1 to 3
disk(i).x=100+i*10
disk(i).y=200+i*10
disk(i).visible=true
disk(i).caption="TEST"
next i
for i=4 to 255
disk(i).visible=false
next
box.button.p1.x=516
box.button.p1.y=378
box.button.p2.x=631
box.button.p2.y=477
do
screenlock
put (0,0),ptr_back ' Hintergrund setzen
key=inkey ' Tastatur abfragen
mouse.reload(mouse) ' \
mouse.button.x=mouse.x ' } Maus abfagen
mouse.button.y=mouse.y ' /
if mouse.key=1 then ' Disketten bewegen
if grab=false then
for i=1 to 255
if inside(disk(i).button,mouse.button)=true and _
disk(i).grab=false and _
disk(i).visible=true then
disk(i).grab=true ' Den Parameter für Greifen einstellen
grab=true ' Keine weiteren Disketten greifen
exit for
end if
next i
end if
if inside(box.button,mouse.button) and box.returned=false then ' Ist der Button für die Diskettenbox gedrückt?
for i=1 to 255
if disk(i).grab=true then ' \
box.grab=true ' \
disk(i).visible=false ' / Lasse eine Diskette in der Box verschwinden
exit for ' /
else
box.grab=false
end if
next i
screenunlock
box.returned=true
if box.grab=false then diskbox(disk(),ptr_disk,ptr_dbox) ' Rufe, wenn keine Diskette abgelegt wurde,
screenlock ' das Boxmenü auf
end if
else
for i=1 to 255:disk(i).grab=false:next i ' \
grab=false ' } Wenn die Maus nich gedrückt wird, setze alles auf "NORMAL"
box.returned=false ' /
end if
for i=255 to 1 step -1 ' Diskettensprites zeichnen
disk(i).button.p1.x=disk(i).x
disk(i).button.p1.y=disk(i).y
disk(i).button.p2.x=disk(i).x+128
disk(i).button.p2.y=disk(i).y+128
if disk(i).grab=true then
disk(i).x=mouse.x-64
disk(i).y=mouse.y-64
end if
if disk(i).visible=true then disk(i).create(ptr_disk,disk(i),i,0)
next i
screenunlock
sleep 10,1
cls
loop until key=chr(27) ' Ende mit ESC
if ptr_disk <> 0 then imagedestroy ptr_back ' \
if ptr_back <> 0 then imagedestroy ptr_disk ' } Sprites-Speicher freigeben
if ptr_dbox <> 0 then imagedestroy ptr_dbox ' /
end
' ---------- Subs --------------------------------------------------------------
sub tmouse.reload(byref mouse as tmouse) ' Maus aktualisieren
with mouse
getmouse .x,.y,.wheel,.key
end with
end sub
sub tdisk.create (buffer as any ptr,disk as tdisk,number as integer,mode as integer) ' Diskette zeichnen
if mode=0 then
put (disk.x,disk.y),buffer,pset
else
put (disk.x,disk.y),buffer,preset
end if
draw string (disk.x+65,disk.y+94),str(number),&HFF0000
draw string (disk.x+55,disk.y+106),disk.caption,&H00FF00
end sub
sub label (byref disk as tdisk,caption as string,prog() as string)' Disketten beschriften
dim i as integer
disk.caption=caption
for i=1 to 255
select case prog(i)
case nul
disk.program(i)=""
case ""
disk.program(i)=disk.program(i)
case else
disk.program(i)=prog(i)
end select
next i
end sub
function inside(square as tsquare,dot as tdot) as integer ' Prüfen, ob ein Punkt in einer Fläche liegt
if (dot.x>square.p1.x and dot.x<square.p2.x) and (dot.y>square.p1.y and dot.y<square.p2.y) then return true
end function
' ********** Diskettenmenü *****************************************************
sub diskbox(disk() as tdisk,sprite as any ptr,back as any ptr)
cls
dim i as integer
dim page as integer
dim show as integer
dim key as string*1
dim mouse as tmouse
dim wheel_old as integer
dim wheel_new as integer
dim wheel_dir as integer
setmouse ,,0
wheel_old=-1
do
screenlock
put(1,1),back,pset
key=inkey
getmouse(mouse.y,mouse.y,wheel_new,mouse.key) ' \
sleep 50,1 ' \
wheel_dir=-sgn(wheel_new-wheel_old) ' / Die Drehrichtung herausfinden
wheel_old=wheel_new ' /
select case wheel_dir
case -1
if show<=1 then
if page<=0 then
show=1
page=0
else
show=1
page-=1
end if
else
show-=1
end if
case 1
if show>=4 then
if page>=251 then
show=4
page=251
else
show=4
page+=1
end if
else
show+=1
end if
end select
for i=1 to 4
if show=i then
put (55+(i-1)*130,165),sprite,and
draw string (120+(i-1)*130,259),str(i+page),&HFF0000
draw string (110+(i-1)*130,271),disk(i+page).caption,&H00FF00
else
put (55+(i-1)*130,165),sprite,pset
draw string (120+(i-1)*130,259),str(i+page),&HFF0000
draw string (110+(i-1)*130,271),disk(i+page).caption,&H00FF00
end if
next i
if mouse.key=1 then disk(show+page).visible=true
screenunlock
sleep 10,1
cls
loop until mouse.key=2
setmouse ,,1
end sub