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_pre05.bas

Uploader:MitgliedAlexander283
Datum/Zeit:24.12.2011 15:20:18
Hinweis: Dieser Quelltext ist Bestandteil des Projekts DiskMgr, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.

' ##############################################################################
' #                                           +-------+                        #
' #      DiskManager  v pre0.5                |   #   |                        #
' #                                           |   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 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

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)

' ---------- 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

do

    put (0,0),ptr_back                                                          ' Hintergrund setzen

    key=inkey                                                                   ' Tastatur abfragen
    mouse.reload(mouse)                                                         ' 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

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 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(mouse)                                                     ' 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(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                                                     ' 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)
    disk.x-=128

    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(mouse(1))
        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