Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Main_pre04.bas
| Uploader: |  Alexander283 |
| Datum/Zeit: | 15.12.2011 22:06:26 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts DiskMgr, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
' ##############################################################################
' # +-------+ #
' # DiskManager v pre0.4 | # | #
' # | 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,clr as integer)
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 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)
declare sub label(disk() as tdisk,number as integer)
' ---------- Sprite-Daten ------------------------------------------------------
const name_back="Background.bmp"
const name_disk="DiskBig.bmp"
const name_dbox="DiskBox.bmp"
const name_menu=""
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) ' Maus abfragen
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
if mouse.key=2 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
screenunlock
label(disk(),i)
screenlock
end if
next i
end if
for i=255 to 1 step -1 ' Alle Disketten aktualisieren
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 ' / Die Disk-Button-Funktion aktualisieren
disk(i).button.p2.y=disk(i).y+128 ' /
if disk(i).grab=true then ' \
disk(i).x=mouse.x-64 ' } Disketten an mausposition, wenn gegriffen
disk(i).y=mouse.y-64 ' /
end if
if disk(i).visible=true then disk(i).create(ptr_disk,disk(i),i,&H0000FF)' Diskette zeichnen
next i
screenunlock
sleep 20,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
.button.x=.x
.button.y=.y
end with
end sub
sub tdisk.create (buffer as any ptr,disk as tdisk,number as integer,clr as integer)' Disketten-zeichnen-Routine
put (disk.x,disk.y),buffer,trans
draw string (disk.x+65,disk.y+94),str(number),&HFF0000
draw string (disk.x+56,disk.y+106),disk.caption,clr
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
while inkey<>"":wend
dim wheel_old as integer
dim wheel_new as integer
dim wheel_dir as integer
dim max as integer=ubound(disk)
wheel_old=-1
setmouse (,,0)
do
screenlock
put(1,1),back,pset
key=inkey
mouse.reload(mouse) '
getmouse(mouse.x,mouse.y,wheel_new)
sleep 50,1 ' \
if mouse.button.x<>-1 and mouse.button.y<>-1 then ' \
wheel_dir=-sgn(wheel_new-wheel_old) ' / Die Drehrichtung herausfinden
wheel_old=wheel_new ' /
end if ' /
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>=(max-4) then
show=4
page=(max-4)
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,add,255
draw string (120+(i-1)*130,259),str(i+page),&HFF0000
draw string (110+(i-1)*130,271),disk(i+page).caption,&H0000FF
else
if disk(i+page).visible=true then
put (55+(i-1)*130,165),sprite,alpha,63
draw string (120+(i-1)*130,259),str(i+page),&HFF0000
draw string (110+(i-1)*130,271),disk(i+page).caption,&H0000FF
else
put (55+(i-1)*130,165),sprite,trans
draw string (120+(i-1)*130,259),str(i+page),&HFF0000
draw string (110+(i-1)*130,271),disk(i+page).caption,&H0000FF
end if
end if
next i
if mouse.key=1 and show<>0 then
disk(show+page).visible=true
disk(show+page).x=1
disk(show+page).y=1
end if
screenunlock
sleep 20,1
cls
loop until (mouse.key=2 or key<>"")
setmouse ,,1
end sub
' ********** Diskette beschriften **********************************************
sub label (disk() as tdisk,number as integer)
dim i as integer
dim finish as integer=0
dim diskname as string
dim key as string
dim mouse as tmouse
while inkey<>"":wend
dim ptr_back as any ptr = imagecreate(640,480)
get(0,0)-(639,479),ptr_back
dim ptr_disk as any ptr=imagecreate(128,128)
bload "DiskBig.bmp",ptr_disk
dim ptr_pen as any ptr=imagecreate(128,128)
bload "Pencil.bmp",ptr_pen
disk(number).caption=""
do
key=inkey ' Tastatur abfragen
mouse.reload(mouse) ' Maus abfragen
screenlock
cls
put (0,0),ptr_back,pset ' Hintergrund zeichnen
for i=255 to 1 step -1
if disk(i).visible=true then
if i=number then
disk(i).create(ptr_disk,disk(i),i,&HFFFF00) ' Disketten zeichnen
else
disk(i).create(ptr_disk,disk(i),i,&H0000FF) ' Disketten zeichnen
end if
end if
next i
put(disk(number).x+62+len(diskname)*8,disk(number).y+114),ptr_pen,trans ' Stift zeichnen
' Hier beginnt die eigentliche Routine der Beschriftung
if key<>"" then
select case asc(left(key,1))
case 13
finish=1
case 8
if len(diskname)>0 then diskname=left(diskname,len(diskname)-1)
case else
if len(diskname)<8 then diskname+=key
end select
disk(number).caption=diskname
end if
screenunlock
sleep 20,1
loop until finish=1
if ptr_back<>0 then imagedestroy ptr_back
if ptr_disk<>0 then imagedestroy ptr_disk
if ptr_pen <>0 then imagedestroy ptr_pen
end sub