Buchempfehlung
MySQL kurz & gut
MySQL kurz & gut
Das preiswerte Taschen- buch stellt MySQL-rele- vante Inhalte systematisch und knapp dar, sodass es sich optimal zum Nach- schlagen beim Pro- grammieren eignet. [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

GuiWindow.bi

Uploader:MitgliedOneCypher
Datum/Zeit:20.09.2009 17:18:49
Hinweis: Dieser Quelltext ist Bestandteil des Projekts GuiPtr, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
Warnung: Es steht bereits eine neuere Version des Quelltexts zur Verfügung. Die hier vorliegende alte Version könnte Fehler enthalten, die in der neuen Version vielleicht ausgebessert wurden.

#include once "GuiPtr.bi"
#include once "Scrollbar.bi"

type NullWindow
    Object as GuiObject ptr
    BackColor as uinteger = RGB(58,110,165)
    BorderColor as ubyte
    BorderStyle as ubyte
    VScrollbar as Scrollbar ptr
    HScrollbar as Scrollbar ptr
    VPos as integer
    HPos as integer
    declare sub StartThread()
    declare sub QuitThread()
    declare sub SleepThread(t as integer = 1)
    declare sub ThreadLock()
    declare sub ThreadUnlock()
    Declare function AddVScrollbar() as Scrollbar ptr
    Declare function AddHScrollbar() as Scrollbar ptr

    declare constructor()
    declare constructor overload(l as integer, t as integer, w as integer, h as integer)
end type

Sub MoveElements(GO as any ptr, e as EventParameter)
    'Dump "G=" & GO
    dim w as GuiObjectControl ptr = GO
    'Dump "W=" & w
    dim o as GuiObject ptr = w->GuiObjectPTR
    'Dump "O=" & O
    dim c as GuiObject ptr
    for i as integer = 1 to o->ChildObjects.count
        c = o->ChildObjects.item(i)
        if c->FixedPosition = 0 then
            c->left += e.mdx
            c->top += e.mdy
        end if
    next
    c->NewDraw = 1
end sub


Sub DragVScrollbar(GO as any ptr, e as EventParameter)
    dim vsb as Scrollbar ptr = go
    dim nw as NullWindow ptr = vsb->Object->Parent->MyObject
    Dim TmpE as EventParameter

    if nw->VPos <> vsb->Value then
        TmpE.mdy = nw->VPos - vsb->Value
        'ump str(nw)
        MoveElements nw, TmpE
        nw->VPos = vsb->Value
    end if
end sub

Sub CalcInnerSizes(GO as any ptr, e as EventParameter)
    dim nw as NullWindow ptr = go
    Dim Child as GuiObject ptr

    if nw->HScrollbar <> 0 then
        nw->HScrollbar->MinValue = 0
        nw->HScrollbar->MaxValue = 0
        nw->HScrollbar->Value = 0
        nw->HPos = 0

    end if

    if nw->VScrollbar <> 0 then
        nw->VScrollbar->MinValue = 0
        nw->VScrollbar->MaxValue = 0
        nw->VScrollbar->Value = 0
        nw->VPos = 0
    end if

    for i as integer = 1 to nw->Object->ChildObjects.Count
        Child = nw->Object->ChildObjects.Item(i)
        if Child->Enabled = 1 then
            if nw->HScrollbar <> 0 then
                if Child->left < 0 then nw->HScrollbar->MinValue = Child->left
                if Child->left + Child->width > nw->Object->Width then nw->HScrollBar->MaxValue = Child->left + Child->width - nw->Object->Width
            end if
            if nw->VScrollbar <> 0 then
                if Child->top < 0 then nw->VScrollbar->MinValue = Child->top
                if Child->top + Child->Height > nw->Object->Height then nw->VScrollBar->MaxValue = Child->top + Child->Height - nw->Object->Height
            end if
        end if
    next

end sub

function nullWindow.AddVScrollbar() as Scrollbar ptr
    dim vsb as Scrollbar ptr = New Scrollbar(Object->width - 18,0,18,Object->Height - Object->ClientTop)
    vsb->Object->AlwaysOnTop = 1
    vsb->Object->FixedPosition = 1
    vsb->Object->PublicEvents->OnMouseDrag = @ DragVScrollbar
    vsb->Object->PublicEvents->SingleClick = @ DragVScrollbar
    VScrollbar = Object->Add(vsb)
    Object->PrivateEvents->OnTick = @CalcInnerSizes
    return VScrollbar
end function

Sub DragHScrollbar(GO as any ptr, e as EventParameter)
    dim hsb as Scrollbar ptr = go
    dim nw as NullWindow ptr = hsb->Object->Parent->MyObject
    Dim TmpE as EventParameter

    if nw->HPos <> hsb->Value then
        TmpE.mdx = nw->HPos - hsb->Value
        'dump stR(TmpE.mdx)
        'dump str(nw)
        MoveElements nw, TmpE
        nw->HPos = hsb->Value

    end if

end sub

function nullWindow.AddHScrollbar() as Scrollbar ptr
    dim hsb as Scrollbar ptr = New Scrollbar(0,Object->Height -18, Object->Width,18)
    hsb->Object->Ignoreclient = 1
    hsb->Object->AlwaysOnTop = 1
    hsb->Object->FixedPosition = 1
    hsb->Object->PublicEvents->OnMouseDrag = @ DragHScrollbar
    hsb->Object->PublicEvents->SingleClick = @ DragHScrollbar
    HScrollbar = Object->Add(hsb)
    Object->PrivateEvents->OnTick = @CalcInnerSizes
    Return HScrollbar
end function


type GuiWindow
    Object as GuiObject ptr
    title as string
    Icon as any ptr
    SafeLeft as integer
    SafeTop as integer
    SafeWidth as integer
    SafeHeight as integer
    maximized as ubyte
    ForeColor as uinteger = RGB(217,229,242)
    BackColor as uinteger = RGB(212,208,200)
    declare sub StartThread()
    declare sub QuitThread()
    declare sub SleepThread(t as integer=1)
    declare sub ThreadLock()
    declare sub ThreadUnlock()
    declare constructor(left as integer, top as integer, w as integer, h as integer, GWindowtitle as string)
end type

'Usual Handles of a Window:


Sub GuiWinResize(GO as any ptr, e as EventParameter)
    dim w as GuiObjectControl ptr = GO
    dim o as GuiObject ptr = w->GuiObjectPTR
    dim oldbuffer as any ptr
    o->width  += e.mdx
    o->height += e.mdy
    oldbuffer = o->Buffer
    Imagedestroy o->ShadowBuffer
    Imagedestroy o->Buffer
    o->ShadowBuffer = imageCreate(o->width+2, o->height +2,RGB(0,0,0))
    o->Buffer = imageCreate(o->width+1, o->height +1,RGB(0,0,0))
    o->NewDraw = 1
    o->root->ChangeBuffer oldbuffer, o->Buffer
    'o->root->Redraw
end sub

Sub ObjectResize(GO as any ptr, e as EventParameter)
    dim w as GuiObjectControl ptr = GO
    dim o as GuiObject ptr = w->GuiObjectPTR
    dim oldbuffer as any ptr
    o->width  += e.mdx
    o->height += e.mdy
    oldbuffer = o->Buffer
    Imagedestroy o->ShadowBuffer
    Imagedestroy o->Buffer
    o->ShadowBuffer = imageCreate(o->width+2, o->height +2,RGB(0,0,0))
    o->Buffer = imageCreate(o->width+1, o->height +1,RGB(0,0,0))
    o->NewDraw = 1
    o->root->ChangeBuffer oldbuffer, o->Buffer
end sub

Sub GuiWinMove(GO as any ptr, e as EventParameter)
    dim w as GuiObjectControl ptr = GO
    dim o as GuiObject ptr = w->GuiObjectPTR
        'put (o->root->left,o->root->top), o->root->ShadowBuffer,PSET
        o->left += e.mdx
        o->top += e.mdy
        'o->NewDraw = 1
        'o->root->Redraw
    'screenunlock
end sub

Sub MaximizeWindow(GO as any ptr, e as EventParameter)
    dim w as GuiWindow ptr = GO
    dim as integer sx, sy
    screencontrol 4, sx, sy
    dim oldbuffer as any ptr
    'dump " " & e.mx & " " & e.my
    'exit sub
    if e.my < 22 then
        if w->maximized = 0 then
            w->maximized = 1
            w->SafeLeft = w->object->left
            w->SafeTop = w->object->Top
            w->SafeWidth = w->object->Width
            w->SafeHeight = w->object->Height
            w->object->left = 0
            if w->object->parent = 0 then
                w->object->Top = 0
                w->object->Width = sx
                w->object->Height = sy
                put (w->object->left,w->object->top), w->object->ShadowBuffer,PSET
                oldbuffer = w->object->buffer
                imagedestroy w->object->shadowbuffer
                imagedestroy w->object->buffer
                w->object->ShadowBuffer = imagecreate(sx+2,sy+2)
                w->object->Buffer = imagecreate(sx+2,sy+2)
                Get (0,0)-(sx,sy), w->object->ShadowBuffer
            else
                w->object->Top = w->object->parent->ClientTop
                w->object->Width = w->object->parent->width
                w->object->height = w->object->parent->height - w->object->parent->ClientTop
                oldbuffer = w->object->buffer
                imagedestroy w->object->buffer
                w->object->Buffer = imagecreate(sx+2,sy+2)
            end if
        else
            w->maximized = 0
            w->object->left = w->SafeLeft
            w->object->Top = w->SafeTop
            w->object->Width = w->SafeWidth
            w->object->Height = w->SafeHeight
            if w->object->parent = 0 then
                put(0,0), w->object->Shadowbuffer,PSET
                oldbuffer = w->object->buffer
                imagedestroy w->object->Shadowbuffer
                imagedestroy w->object->buffer
                w->object->Shadowbuffer = imagecreate(w->object->Width+2,w->object->Height+2)
                w->object->Buffer = imagecreate(w->object->Width+2,w->object->Height+2)
            else
                oldbuffer = w->object->buffer
                imagedestroy w->object->buffer
                w->object->Buffer = imagecreate(w->object->Width+2,w->object->Height+2)
            end if
        end if
        w->object->ChangeBuffer oldbuffer, w->object->buffer
        w->object->root->redraw
    end if
end sub

Sub NullWinBehavior(GO as any ptr, e as EventParameter)
    if e.mb = 3 then
        MoveElements GO, e
    end if
end sub

sub GuiWinBehavior(GO as any ptr, e as EventParameter)
    dim w as GuiWindow ptr = GO
    if w->Maximized = 0 then
        if e.mb = 1 then GuiWinMove GO, e
        if e.mb = 2 then GuiWinResize GO, e
        if e.mb = 3 then MoveElements GO, e
    end if
end sub

Sub ReDrawGuiWin(GWindowPTR as any ptr)
    dim w as GuiWindow ptr = GWindowPTR
    with *w
        with *w->Object
            line .buffer, (0,0)-(.width,.height), w->BackColor, BF
            'line .buffer, (0,0)-(.width, 22 ), RGB(166,202,240), BF
            line .buffer, (0,0)-(.width, 22 ), w->ForeColor, BF
            line .buffer, (0,0)-(.width,.height), RGB(0,0,0), B

            'line .buffer, (0,23)-(.width,23), RGB(255,255,255)
            'line .buffer, (0,23)-(0, .height), RGB(255,255,255)
            if w->Icon <> 0 then
                draw string .buffer, (23, 5), w->title,RGB(0,0,0)
                line .buffer, (4,4)-(18, 18),RGB(255,255,255),BF
            else
                draw string .buffer, (6, 5), w->title,RGB(0,0,0)
            end if
        end with
    end with
end sub


Sub RedrawNullWindow(GO as any ptr)
    dim nw as NullWindow ptr = GO
    with *nw->Object
        line .buffer,(0,0)-(.width,.height),nw->BackColor,BF
        select case nw->BorderStyle
        Case 0
        case 1
            line .buffer, (0, 0)-(0 + .width, 0 + .height),nw->BorderColor,B
        case 2
            line .buffer, (0, 0)-(0 + .width, 0 + .height),RGB(64,64,64),B
            line .buffer, (0, 0)-(0, 0 + .height),RGB(255,255,255)
            line .buffer, (0, 0)-(0 + .width, 0),RGB(255,255,255)
        end select
    end with
end sub


'Threadhandles:

Sub WindowThread(GO as any ptr)
    dim W as NullWindow ptr = GO
    dim TC as ubyte
    do
        MutexLock w->Object->ThreadMutex
        w->Object->DoEvents
        TC = w->Object->ThreadCancel
        MutexUnlock w->Object->ThreadMutex
    loop until TC = 1
    TC = 0
end sub


Sub GuiWindow.QuitThread()
    MutexLock Object->ThreadMutex
    Object->ThreadCancel = 1
    MutexUnLock Object->ThreadMutex
    ThreadWait Object->ThreadID
end sub

sub GuiWindow.ThreadLock()
    mutexlock Object->ThreadMutex
end sub

sub GuiWindow.ThreadUnlock()
    mutexunlock Object->ThreadMutex
end sub

sub GuiWindow.SleepThread(t as integer = 1)
    MutexLock Object->ThreadMutex
    Sleep t
    MutexUnLock Object->ThreadMutex
end sub

Sub GuiWindow.StartThread()
    Object->ThreadID = ThreadCreate(Cast(Any Ptr,@WindowThread), @This)
end sub

Sub NullWindow.QuitThread()
    MutexLock Object->ThreadMutex
    Object->ThreadCancel = 1
    MutexUnLock Object->ThreadMutex
    ThreadWait Object->ThreadID
end sub

sub NullWindow.ThreadLock()
    mutexlock Object->ThreadMutex
end sub

sub NullWindow.ThreadUnlock()
    mutexunlock Object->ThreadMutex
end sub

sub NullWindow.SleepThread(t as integer = 1)
    MutexLock Object->ThreadMutex
    Sleep t
    MutexUnLock Object->ThreadMutex
end sub

Sub NullWindow.StartThread()
    Object->ThreadID = ThreadCreate(Cast(Any Ptr,@WindowThread), @This)
end sub


constructor NullWindow()
    dim as integer sx, sy
    screencontrol 4, sx, sy
    Object = new GuiObject(@This)
    with *Object
        .ClassName = "NullWindow"
        .left = 0
        .top = 0
        .width = sx
        .height = sy
        .PrivateEvents = new Events
        .PrivateEvents->OnDraw = @RedrawNullWindow
        .PrivateEvents->OnMouseDrag = @NullWinBehavior
        .buffer = imagecreate(sx+1,sy+1,RGB(0,0,128))
        .ShadowBuffer = .buffer 'imagecreate(sx+1,sy+1)
    end with

    'Controlelements
end constructor

constructor NullWindow(l as integer, t as integer, w as integer, h as integer)
    Object = new GuiObject(@This)
    with *Object
        .ClassName = "NullWindow"
        .left = l
        .top = t
        .width = w
        .height = h
        .PrivateEvents = new Events
        .PrivateEvents->OnDraw = @RedrawNullWindow
        .PrivateEvents->OnMouseDrag = @NullWinBehavior
        .buffer = imagecreate(w+1,h+1,RGB(0,0,128))
        .ShadowBuffer = imagecreate(w+1,h+1,RGB(0,0,128))
    end with

    'Controlelements
end constructor

constructor GuiWindow(left as integer, top as integer, w as integer, h as integer, GWindowtitle as string)
    Object = new GuiObject(@This)
    with *Object
        .ClassName = "GuiWindow"
        .left = left
        .top = top
        .width = w
        .height = h
        .ClientTop = 23
        .buffer = imagecreate(w+1,h+1)
        .ShadowBuffer = imagecreate(w+1,h+1)
        .PrivateEvents = new Events
        with *.PrivateEvents
            .OnDraw = @ReDrawGuiWin
            .OnMouseDrag = @GuiWinBehavior
            .DoubleClick = @MaximizeWindow
        end with
    end with

    'Controlelements
    Title = GWindowTitle
end constructor