Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
GuiPtr.bi
| Uploader: |  OneCypher |
| Datum/Zeit: | 20.09.2009 17:00:30 |
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 "Collection.bi"
sub dump(msg as string)
open cons for output as #1
print #1, msg
close #1
end sub
type EventParameter
Key as string
mx as integer
my as integer
ms as integer
mb as integer
mdx as integer
mdy as integer
declare constructor()
end type
constructor EventParameter()
key = "NULL"
mx = 0
my = 0
ms = 0
mb = 0
mdx = 0
mdy = 0
end constructor
sub DummyEvent1(TMP as any ptr)
end sub
sub DummyEvent2(TMP as any ptr, e as EventParameter)
end sub
declare sub CallRoot(GO as any ptr, e as EventParameter)
type Events
SingleClick as sub (GO as any ptr, e as EventParameter) = @CallRoot 'Einfacher Klick
DoubleClick as sub (GO as any ptr, e as EventParameter) = @CallRoot 'Doppel Klick
OnMouseOver as sub (GO as any ptr, e as EventParameter) = @DummyEvent2 'Wenn die Maus über das Bedienelement fährt
OnMouseDown as sub (GO as any ptr, e as EventParameter) = @DummyEvent2 'Wenn die Maustaste runtergedrückt wurde
OnMouseDrag as sub (GO as any ptr, e as EventParameter) = @DummyEvent2 'Wenn die Maustaste gedrückt und die Mausposition verändert wird
OnMouseUp as sub (GO as any ptr, e as EventParameter) = @DummyEvent2 'Wenn die Maustaste losgelassen wird
OnKeyPress as sub (GO as any ptr, e as EventParameter) = @DummyEvent2 'Wenn eine Tastatur-Taste gedrückt wurde
OnEnter as sub (GO as any ptr, e as EventParameter) = @CallRoot 'Wenn ENTER gedrückt wurde
OnTick as sub (GO as any ptr, e as EventParameter) = @DummyEvent2 'Wenn die Ereignisse eines Bedienelements aufgerufen werden
OnSelection as sub (GO as any ptr) = @DummyEvent1 'Wenn das Bedienelement selektiert wurde
OnDraw as sub (GO as any ptr) = @DummyEvent1 'Wenn das Bedienelement gezeichnet werden soll
end type
Type GuiObjectControl
GuiObjectPTR as any ptr
end type
type GuiObject
name as string 'Name des Objekts (wird vom Klassenname abgeleitet)
ClassName as string 'Name der Klasse
'Indizierung des Objekts beeinflussen:
FixedIndex as ubyte 'Wenn 1 dann schiebt sich das Objekt beim Anklicken nicht in den Vordergrund
FixedPosition as ubyte 'Wenn 1 dann soll das Objekt nicht verschoben werden können..
AlwaysOnTop as ubyte 'Wenn 1 dann erscheint das Objekt immer im Vordergrund
IgnoreClient as ubyte 'Wenn 1 dann verschiebt sich das Objekt beim erstellen nicht um die Clientposition
'LaufzeitMessungen:
EventFrames as integer 'Zum ermitteln der FPS eines Bedienelements
EventTimer as double
EventFPS as integer 'Frames per Second des Objekts
'Das "Aussehen" des Objekts:
left as integer 'Linker Abstand
top as integer 'Oberer Abstand
width as integer 'Breite
height as integer 'Höhe
buffer as any ptr 'GrafikPuffer
ShadowBuffer as any ptr 'SchattenPuffer (Der Puffer "behält sich den Hintergrund des Objekts)
Transparency as ubyte 'Die transparenz des Objekts 0=Sichtbar 255=Unsichtbar
'Beeinflussung der Kind-Objekte
ClientLeft as integer 'Schiebt alle neue Objekte weiter nach links
ClientTop as integer 'Schiebt alle neue Objekte weiter nach unten
'Ereignisse:
PublicEvents as Events ptr = new Events 'Öffentliche Ereignisse (darf der Benutzer festlegen)
PrivateEvents as Events ptr 'Private Ereignisse (darf nur das Objekt selbst verwenden)
LastClick as double 'Die Zeit seit dem letzten MausKlick (zum ermitteln eines DoubleClicks)
NewDraw as ubyte = 1 'Wenn 1 durchläuft das Objekt immer einen kompletten Zeichenvorgang
Enabled as ubyte = 1 'Wenn 1 ist das Objekt angeschaltet und liefert Ereignisse. Wenn 0 liefert es keine ereignisse mehr und die Kind-Objekte werden nicht weiter ausgeführt
Selection as GuiObject ptr 'Wenn das Objekt ein Root ist findet man hier den Zeiger auf das grade selektierte Objekt
SelectionIdx as integer 'Wenn das Objekt mehrere Kind-Objekte hat, findet man dort den Index des grade selektierten Kindes. (Wird mit TAB durchiteriert)
'Hierarchiestufen des Objekts:
MyObject as any ptr 'Zeigt auf das Bedienelement
ChildObjects as Collection 'Hier sind die Kind-Objekte gespeichert.
Parent as GuiObject ptr 'Zurück zum Eltern-Objekt
root as GuiObject ptr 'Zurück zum untersten Objekt
'Object Funktionen:
declare function Add(GOC as any ptr) as any ptr 'Fügt ein Kind-Objekt hinzu
declare function DoEvents(byval e as EventParameter = EventParameter) as uinteger 'Führt die Ereignisse des Objekts aus. (Der Parameter e ist optional und wird nur Objekt-Intern verwendet!)
declare sub ReDraw 'Zeichnet das Objekt im jeweiligen Buffer und dessen Kinder rekursiv neu
declare sub ReTick(e as EventParameter) 'Tickt jedes Objekt rekursiv an
declare sub ChangeBuffer (FromBuffer as any ptr, ToBuffer as any ptr) 'Änder die Grafikpuffer der Kind-Objekte
declare constructor(GO as any ptr) 'Objekt Konstruktor wird beim Initialisieren des Bedienelementes mit dem Parameter @This aufgerufen
declare sub SelectNext() 'Selektiert das nächste Bedienelement.
declare function CountClasses(ClsName as string) as integer
'Thread-Variablen:
ThreadMutex as any ptr
ThreadCancel as ubyte
ThreadID as any ptr
ReturnValue as uinteger 'Hier kann man einen Wert als rückgabe-Information hinterlegen
'Testroutinen:
declare sub DumpObjects(s as string = "")
end type
sub GuiObject.DumpObjects(s as string = "")
Dim Child as GuiObject ptr
dump s & Name
for i as integer = 1 to ChildObjects.Count
Child = ChildObjects.Item(i)
Child->DumpObjects(s & " ")
next
end sub
function GuiObject.CountClasses(ClsName as string) as integer
Dim Child as GuiObject ptr
dim c as integer
if ClassName = ClsName then c +=1
for i as integer = 1 to ChildObjects.Count
Child = ChildObjects.Item(i)
c += Child->CountClasses(ClsName)
next
return c
end function
Sub CallRoot(GO as any ptr, e as EventParameter)
dim g as GuiObjectControl ptr = GO
dim o as GuiObject ptr = g->GuiObjectPTR
o->Root->ReturnValue = cast(uinteger, GO)
end sub
Sub GuiObject.SelectNext()
dim o as GuiObject ptr
do
if root->Selection = @This then
SelectionIdx += 1
If SelectionIdx > ChildObjects.Count then
SelectionIdx = 0
if parent <> 0 then
root->selection = parent
parent->SelectNext
else
root->Selection = 0
end if
exit sub
else
do
o = ChildObjects.item(SelectionIdx)
if o->enabled = 0 then
SelectionIdx += 1
else
o->SelectNext
end if
loop until o->Enabled = 1 or SelectionIdx > ChildObjects.count
end if
else
root->Selection = @This
PrivateEvents->OnSelection(MyObject)
PublicEvents->OnSelection(MyObject)
end if
loop until SelectionIdx <= ChildObjects.Count
end sub
sub GuiObject.ChangeBuffer(FromBuffer as any ptr, ToBuffer as any ptr)
Dim Child as GuiObject ptr
if Buffer = FromBuffer then Buffer = ToBuffer
for i as integer = 1 to ChildObjects.Count
Child = ChildObjects.Item(i)
Child->ChangeBuffer FromBuffer, ToBuffer
next
end sub
function GuiObject.Add(GOC as any ptr) as any ptr
Dim NewObject as GuiObjectControl ptr = GOC
Dim NewGuiObject as GuiObject ptr = NewObject->GuiObjectPTR
if NewGuiObject->Buffer = 0 then
NewGuiObject->Buffer = Buffer
end if
NewGuiObject->parent = @This
if root = 0 then
NewGuiObject->root = @This
else
NewGuiObject->root = root
end if
if NewGuiObject->IgnoreClient = 0 then
NewGuiObject->Left += ClientLeft
NewGuiObject->Top += ClientTop
end if
ChildObjects.add NewObject->GuiObjectPTR
NewGuiObject->Name = NewGuiObject->ClassName & root->CountClasses(NewGuiObject->ClassName)
return GOC
end function
function GuiObject.DoEvents(byval e as EventParameter = EventParameter) as uinteger
Dim Child as GuiObject ptr
dim TmpChild as GuiObject ptr
'Dim NewEvent as EventParameter
dim as integer tmpx1, tmpy1, tmpx2, tmpy2
dim OtherEvents as ubyte
Dim TmpTime as double
'Wenn das Objekt angeschaltet ist....
if enabled then
'... zähle die Frames und setze den Timer
EventFrames += 1
if EventTimer = 0 then EventTimer = timer
'Wenn dieses Objekt ein Root ist dann lese Maus und tastatur ein...
if root = @This then
e.key = inkey
getmouse e.mx,e.my,e.ms,e.mb
'Wenn TAB gedrückt wurde soll die Selektion einen Schritt weiterrücken
if e.key = chr(9) then
if selection <> 0 then
Selection->SelectNext
else
SelectNext
end if
end if
end if
e.mx -= left: e.my -= top 'Damit jedes Objekt die Mauskoordinaten relativ zu sich selbst bekommt
'Schau nach ob das Objekt selektiert wurde...
if root->Selection = @This then
if e.key <> "" and e.key <> CHR(9) then
if e.key = CHR(13) then '... und ENTER gedrückt wurde, löse entsprechende Events aus
PrivateEvents->SingleClick(MyObject, e)
PublicEvents->SingleClick(MyObject, e)
PrivateEvents->OnEnter(MyObject, e)
PublicEvents->OnEnter(MyObject, e)
else '.. und wenn was anderes gedrückt wurde löse auch entsprechende Events aus
PrivateEvents->OnKeyPress(MyObject, e)
PublicEvents->OnKeyPress(MyObject, e)
end if
end if
end if
'Hier wird die AlwaysOnTop-Funktion realsiert. (Der Index eines Objekt, welches mit AlwaysOnTop markiert wurde, wird nach hinten verschoben)
for i as integer = 1 to ChildObjects.count
Child = ChildObjects.item(i)
If Child->AlwaysOnTop and Child->Enabled then
TmpChild = ChildObjects.Item(ChildObjects.count)
ChildObjects.Item(ChildObjects.count) = Child
ChildObjects.Item(i) = TmpChild
end if
next
'Wenn das Objekt Root ist, dann löse die rekursive Redraw-Funktion aus (zeichnet nicht nur sich selbst, sondern auch die Kind-Objekte)
'Und löse rekursiv das OnTick-Event aus
if root = @This then
Redraw
ReTick e
end if
'Um die Reihenfolge der gezeichneten Objekte mit den Ereignissen übereinstimmen zu lassen
'müssen die Kind-Objekte von hinten durchlaufen werden und auf Ereignisse geprüft werden
if e.mx > 0 and e.mx < width then
if e.my > 0 and e.my < height then
for i as integer = ChildObjects.count to 1 step -1
Child = ChildObjects.item(i)
if Child->Enabled = 1 then
getmouse tmpx1, tmpy1 'Mit TmpX1,X2 und TmpY1,Y2 wird die relative Mausveränderung nach den Kind-Ereignissen berechnet
Child->DoEvents e
getmouse tmpx2, tmpy2
tmpx2 -= tmpx1: tmpy2 -= tmpy1
e.mx += tmpx2: e.my += tmpy2 'Hier wird die relative Mausveränderung nach den Kind-Ereignissen übernommen
if e.mx > Child->Left and e.mx < Child->Left + Child->Width then
if e.my > Child->top and e.my < Child->top + Child->height then
OtherEvents = 1
if (e.mb > 0 or e.key <> "") and Child->FixedIndex = 0 then
for i2 as integer = i to ChildObjects.count -1
ChildObjects.item(i2) = ChildObjects.item(i2+1)
next
ChildObjects.item(ChildObjects.count) = Child
end if
exit for
end if
end if
end if
next
'Wenn kein Kind-Ereignis vorangegangen ist, dann gehen wir in die Ereignisse des aktuellen Objekts
if OtherEvents = 0 then
'Wenn die Maus innerhalb des aktuellen Objekts liegt...
'...lösen wir das entsprechende Ereignis aus
PrivateEvents->OnMouseOver(MyObject, e)
PublicEvents->OnMouseOver(MyObject, e)
'Wenn eine Maustaste gedrückt wurde...
if e.mb <> 0 then
root->selection = @This '... wird die Selektion aufs aktuelle Objekt gelegt
'...lösen wir das entsprechende Ereignis aus
PrivateEvents->OnMouseDown(MyObject, e)
PublicEvents->OnMouseDown(MyObject, e)
getmouse tmpx1,tmpy1 'Mit TmpX1,X2 und TmpY1,Y2 wird die relative Mausbewegung für die Ereignisse des Objekts berechnet
while e.mb > 0
getmouse tmpx2,tmpy2,,e.mb
if tmpx2 >= 0 and tmpy2 >= 0 then
if tmpx2 <> tmpx1 or tmpy2 <> tmpy1 then
e.mdx = tmpx2 - tmpx1
e.mdy = tmpy2 - tmpy1
e.mx += e.mdx: e.my += e.mdy 'Hier wird die relative Mausveränderung für die Ereignisse übernommen
tmpx1 = tmpx2: tmpy1 = tmpy2
e.key = inkey
PrivateEvents->OnMouseDrag(MyObject, e)
PublicEvents->OnMouseDrag(MyObject, e)
end if
end if
root->ReDraw
wend
'Hier wird geprüft ob nach dem Tastendruck die Mausposition noch innerhalb des Objekts liegt
if e.mx > 0 and e.mx < width and e.my > 0 and e.my < Height then
'Wenn die Maus noch innerhalb des Objekts liegt prüfen wir ob ein Doppelklick vorliegt
if Timer <= LastClick + 0.4 then
PrivateEvents->DoubleClick(MyObject, e)
PublicEvents->DoubleClick(MyObject, e)
LastClick = 0
else
PrivateEvents->SingleClick(MyObject, e)
PublicEvents->SingleClick(MyObject, e)
LastClick = Timer
end if
end if
'Hier wird die Maustaste aus losgelassen angesehen und das entsprechende Event wird ausgelöst
PrivateEvents->OnMouseUp(MyObject, e)
PublicEvents->OnMouseUp(MyObject, e)
end if
end if
end if
end if
'Hier werden die FPS des Objekts berechnet
TmpTime = Timer
if EventTimer + 1.5 <= TmpTime then 'Alle 0.1 sekunden werden die FPS hochgerechnet
TmpTime -= EventTimer
EventFPS = EventFrames / TmpTime
EventFrames = 0
EventTimer = Timer
end if
end if
return ReturnValue
end function
Sub GuiObject.ReTick(e as EventParameter)
'Wird immer aufgerufen wenn das Objekt angeschaltet ist
Dim Child as GuiObject ptr
Dim NewEvent as EventParameter
if enabled = 1 then
PrivateEvents->OnTick(MyObject, e)
PublicEvents->OnTick(MyObject, e)
for i as integer = 1 to ChildObjects.count
Child = ChildObjects.item(i)
with NewEvent
.key = e.key
.mx = e.mx - Child->left 'Damit wird festgelegt das die Ereignisse eines Objekts
.my = e.my - Child->top 'die Mausdaten relativ zu sich selbst erhält.
.ms = e.ms
.mb = e.mb
end with
Child->ReTick NewEvent
next
end if
end sub
Sub GuiObject.Redraw
'Hier wird das aktuelle Objekt und dessen Kind-Objekte gezeichnet
Dim Child as GuiObject ptr
dim as integer ShadowW, ShadowH
if Enabled = 1 then
'Falls das Objekt angeschaltet ist, werden die Entsprechenden "Zeichnen-Ereignisse" des aktuellen objekts aufgerufen
PrivateEvents->OnDraw(MyObject)
PublicEvents->OnDraw(MyObject)
'Und hier wird ein Rahmen ums objekt gemalt, falls das aktuelle Objekt selektiert ist
if root->selection = @This then
if parent <> 0 then
if parent->Buffer <> buffer then
line buffer, (0+1,0+1)-(width-1, height-1), RGB(0,0,0),B, &b1010101010101010
else
line buffer, (left+1,top+1)-(left + width-1, top + height-1), RGB(0,0,0),B, &b1010101010101010
end if
else
'Wenn man eine Selection auf einem Root Element zeigen möchte folgende zeile auskommentieren:
' line buffer, (0+1,0+1)-(width-1, height-1), RGB(0,0,0),B, &b1010101010101010
end if
end if
'Hier werden die Kind-Objekte durchlaufen und gemalt
for i as integer = 1 to ChildObjects.count
Child = ChildObjects.item(i)
Child->ReDraw
next
'Hier wird alles auf dem Bildschirm ausgegeben, falls wir es mit einem Root-Element zu tun haben...
if root = @This then
if ShadowBuffer <> 0 then
ImageInfo buffer, ShadowW, ShadowH
if NewDraw = 1 then
Get (Left, top)-(left + ShadowW, top + ShadowH -1), ShadowBuffer
NewDraw = 0
end if
end if
if Buffer <> 0 then
screenlock
put (left, top),buffer,ALPHA, 255 - transparency
screenunlock
end if
else
'Wenn wir kein Root-Element vorliegen haben, aber dennoch einen eigenen Buffer, wird dieser Buffer in den buffer des Eltern-Elements gezeichnet
if buffer <> parent->buffer then
put parent->buffer,(left, top),buffer, Alpha, 255 - transparency
end if
end if
end if
end sub
Constructor GuiObject(GO as any ptr)
'Der Konstruktor für das GuiObjekt ist relativ simple:
'Der Konstruktor braucht lediglich einen Zeiger aufs eigentliche Objekt
MyObject = GO
'Und er sieht sich in erster linie selbst als Root
'Wenn er selbst nicht root ist, wird ihm das von seinem Eltern-Objekt mitgeteilt bzw "überschrieben"
root = @This
end constructor