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

Uploader:MitgliedAlexander283
Datum/Zeit:14.12.2011 16:41:07
Hinweis: Dieser Quelltext ist Bestandteil des Projekts DiskMgr, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.

' ##############################################################################
' #                                           +-------+                        #
' #      DiskManager  v pre0.3                |   #   |                        #
' #                                           |   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)
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)
declare sub label(disk as tdisk,caption as string,prog() as string)

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

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

    dim max as integer=ubound(disk)

    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>=(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,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
                    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,&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
                end if
            next i

            if mouse.key=1 then
                disk(show+page).visible=true
                disk(show+page).x=1
                disk(show+page).y=1
            end if

        screenunlock
        sleep 10,1
        cls
    loop until (mouse.key=2 or key<>"")
    setmouse ,,1
end sub

' ********** Diskette beschriften **********************************************

sub label (byref disk as tdisk,caption as string,prog() as string)              ' Disketten beschriften
    dim i as integer

    ' ==================================================================================================================
    ' ==================================================================================================================
    ' ==================================================================================================================
    ' =============================================== HIER WEITERMACHEN !! =============================================
    ' ==================================================================================================================
    ' ==================================================================================================================
    ' ==================================================================================================================

    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