Buchempfehlung
Visual Basic 6 Kochbuch
Visual Basic 6 Kochbuch
Viele praktische Tipps zum Programmieren mit Visual Basic 6, die sich oft auch auf FB übertragen lassen. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

Main_v1.0.bas

Uploader:MitgliedAlexander283
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