Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Main_v1.0.bas
| Uploader: |  Alexander283 |
| Datum/Zeit: | 14.02.2012 21:53:50 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts DiskMgr, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
' ##############################################################################
' # +-------+ #
' # DiskManager v 1.0 | # | #
' # | 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()
end type
type tbox
as tsquare button
as integer returned
as integer grab
end type
type tprog
as tsquare button
as integer returned
end type
' ---------- Deklarationen -----------------------------------------------------
dim Mouse as tmouse
dim Disk(1 to 255) as tdisk
dim box as tbox
dim prog as tprog
dim grab as integer
dim key as string*1
dim i as integer
dim shared retry as integer=true
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)
declare sub adress(byref disk as tdisk)
declare sub save (disk() as tdisk)
declare sub load (disk() as tdisk)
' ---------- Sprite-Daten ------------------------------------------------------
const name_back="Background.bmp"
const name_disk="DiskBig.bmp"
const name_dbox="DiskBox.bmp"
const name_prog="ProgMenu.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
prog.button.p1.x=504
prog.button.p1.y=11
prog.button.p2.x=631
prog.button.p2.y=105
' Lade-Routine
load(disk())
do
do
put (0,0),ptr_back ' Hintergrund setzen
key=inkey ' Tastatur abfragen
mouse.reload() ' Maus abfragen
screenlock
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
if inside(prog.button,mouse.button)=true then
for i=1 to 255
if disk(i).grab=true and prog.returned=false then
prog.returned=true
screenunlock
adress(disk(i))
screenlock
exit for
end if
next i
end if
else
for i=1 to 255:disk(i).grab=false:next i ' \
grab=false ' \
prog.returned=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
' SPEICHER-ROUTINE
save(disk())
loop until retry=false
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() ' Maus aktualisieren
with this
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 incoming as integer=true
dim number as integer=0
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
key=inkey
mouse.reload() ' Maus aktualisieren
if incoming=true then
if mouse.key=0 then incoming=false
mouse.key=0
end if
screenlock
put(1,1),back,pset
getmouse(mouse.x,mouse.y,wheel_new) ' \
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
if disk(show+page).visible=false then number+=1
disk(show+page).visible=true
disk(show+page).x=(number-1)*32
disk(show+page).y=(number-1)*32
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) ' Erstelle Hintergrund-Sprite
get(0,0)-(639,479),ptr_back ' = Ehemaliger Hintergrund
dim ptr_disk as any ptr=imagecreate(128,128) ' Erstelle Disk-Sprite
bload "DiskBig.bmp",ptr_disk
dim ptr_pen as any ptr=imagecreate(128,128) ' erstelle Stift-Sprite
bload "Pencil.bmp",ptr_pen
disk(number).caption="" ' Lösche alte Caption
do
key=inkey ' Tastatur abfragen
mouse.reload() ' 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 ' Beginne, wenn eine Taste gedrückt wird
select case asc(left(key,1)) ' Was für ein Zeichen ist KEY ?
case 13 ' -> Enter
finish=1 ' Beende LABEL
case 8 ' -> Backspace
if len(diskname)>0 then diskname=left(diskname,len(diskname)-1)' Lösche letztes zeichen
case else ' -> Sonst
if len(diskname)<8 then diskname+=key ' Füge gegebenes Zeichen zum namen hinzu
end select
disk(number).caption=diskname ' Abtualisiere die Disk.Caption
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 ' } Speicherbereinigung von Sprites
if ptr_pen <>0 then imagedestroy ptr_pen ' /
end sub
' ********** Laufwerksmenü *****************************************************
sub adress(byref disk as tdisk)
dim ptr_back as any ptr=imagecreate(640,480)
bload "Progmenu.bmp",ptr_back
dim mouse(2) as tmouse
dim mouse_dir(2) as integer
dim key as string
dim cursor as tdot
dim page as integer
dim i as integer
dim n as integer
dim finish as integer
dim show_cap as string
' Variablen für Cursorbewegung
dim MK_old(255) as integer
dim MK_new(255) as integer
dim getchr as integer
dim p_old as integer
dim p_new as integer
' Variablen für die Radbewegung
dim wheel_new as integer
dim wheel_old as integer
dim wheel_dir as integer
mouse(2).x=1
mouse(2).y=1
cursor.x=1
cursor.y=1
if disk.caption="" then show_cap="No Name" else show_cap=disk.caption
do
mouse(1).reload()
wheel_new=mouse(1).wheel
sleep 10,1 ' \
if mouse(1).button.x<>-1 and mouse(1).button.y<>-1 then ' \
mouse_dir(1)=mouse(2).x-mouse(1).x ' } Die Bewegung herausfinden
mouse_dir(2)=mouse(2).y-mouse(1).y ' /
mouse(2)=mouse(1) ' /
end if
wheel_dir=-sgn(wheel_new-wheel_old)
wheel_old=wheel_new
key=inkey
' Pfeilastenabfrage
p_old=p_new
for i=1 to 150
MK_old(i)=MK_new(i)
MK_new(i)=multikey(i)
if MK_new(i)=0 then
if MK_old(i)=0 then
' Empty
else
if i=&H01 then finish=1
p_new=false
end if
else
if MK_old(i)=0 then
p_new=true
else
' Empty
end if
end if
next i
getchr=p_new-p_old
' Ende Pfeiltasten
while len(inkey):wend
screenlock
cls
put (0,0),ptr_back,pset ' Hintergrund setzen
if mouse(1).key=1 then
if (mouse(1).y-6)/12>1 then cursor.y=(mouse(1).y-6)/12 ' Bei Mausklick den Cursor versetzen
end if
select case wheel_dir ' \
case -1 ' \
if page>0 then page-=1 ' \
case 1 ' / Bei Mausrad-Drehung die Seite scrollen
if page<215 then page+=1 ' /
end select ' /
select case asc(left(key,1))
case 32 to 165 ' Sinnvolle Taste
if cursor.x<33 then disk.program(cursor.y+page)+=left(key,1)
case 8 ' Backspace
disk.program(cursor.y+page)=left(disk.program(cursor.y+page),len(disk.program(cursor.y+page))-1)
if cursor.x=1 then
if page>0 and cursor.y=1 then
page-=1
else
cursor.y-=1
end if
end if
end select
if getchr=true then
if multikey(&H48) then ' Oben
if cursor.y=1 and page>0 then
page-=1
else
cursor.y-=1
end if
end if
if multikey(&H50) or multikey(&H1C) then ' Enter oder Unten
if cursor.y=40 then
if page<215 then
page+=1
end if
else
cursor.y+=1
end if
end if
end if
cursor.x=len(disk.program(cursor.y+page))+1 ' Den Cursor-X an die Rechte Seite setzen
if cursor.y<1 then cursor.y=1 ' \
if cursor.y>40 then cursor.y=40 ' / Überprüfen, ob Cursor-Y im güligen Bereich liegt
draw string (544,0),show_cap,&H009900
if cursor.x=33 then line(cursor.x*12+38,(cursor.y-1)*12)-(cursor.x*12+46,(cursor.y-1)*12+12),&HFF0000,BF
for n=1 to 40 ' Zeichen-Routine von Strings
for i=1 to 32
if i=cursor.x and n=cursor.y then
line(i*12+38,(n-1)*12)-(i*12+46,(n-1)*12+12),&H00FF00,BF
draw string(i*12+38,(n-1)*12),mid(disk.program(n+page),i,1),&HAF0000
else
draw string(i*12+38,(n-1)*12),mid(disk.program(n+page),i,1),&H0000AF
end if
next i
draw string (1,(n-1)*12),str(n+page),&H00AF00
next n
screenunlock
sleep 10,1
loop until finish=1
disk.x=128
disk.y=128
if ptr_back<>0 then imagedestroy ptr_back
while len(inkey):wend
end sub
' ********** SPEICHERN *********************************************************
sub save(disk() as tdisk)
dim i as integer
dim n as integer
dim rpos as integer
dim choice as string*1
dim outstr as string
dim ff as integer=freefile
for i=1 to 255
for n=1 to 255
for rpos=1 to len(disk(i).program(n))
if mid(disk(i).program(n),rpos,1)="," then
mid(disk(i).program(n),rpos,1)="."
end if
next rpos
next n
next i
if open("DISKS.DAT" for binary as #ff)=0 then
retry=false
for i=1 to ubound(disk)
outstr=disk(i).caption+string(8-len(disk(i).caption),255)+","
for n=1 to 255
if disk(i).program(n)<>"" then
outstr+=disk(i).program(n)+","
else
outstr+=chr(27)+","
end if
next n
print #ff,outstr
next i
else
print "ATTENTION! Data could not be saved!"
input "Do you wish to return to workbench? ";choice
if ucase(choice)="Y" then retry=true else retry=false
exit sub
end if
end sub
' ********** LADEN *************************************************************
sub load(disk() as tdisk)
dim i as integer
dim n as integer
dim rpos as integer
dim inpstr as string
dim choice as string*1
dim ff as integer=freefile
if open("DISKS.DAT" for input as #ff)=0 then
i=0
do ' Disketten Wechsel
i+=1
line input #ff,inpstr
print inpstr
inpstr:sleep 5,1
' Caption
for n=1 to 8 'Caption Zeichen
if mid(inpstr,n,1)<>chr(255) then disk(i).caption+=mid(inpstr,n,1)
next n
' Programme
n=1
for rpos=1 to len(inpstr)
if rpos<10 then continue for
select case mid(inpstr,rpos,1)
case chr(27)
disk(i).program(n)=""
case ","
n+=1
case else
disk(i).program(n)+=mid(inpstr,rpos,1)
end select
next rpos
loop until i>254
else
print "ATTENTION! Data could not be load!"
input "Do you wish to retry? ";choice
if ucase(choice)="Y" then retry=true else retry=false
exit sub
end if
end sub