Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
SimpleGUI.BI
| Uploader: |  Muttonhead |
| Datum/Zeit: | 20.10.2008 22:18:40 |
'Begin SimpleGUI.bi
'##############################################################################
'##############################################################################
dim shared as integer maxgad=64
type Gadget
gadtype as integer ' Gadget Typ
mode as integer ' Gadget Modus
reply as integer ' Antwort
posx as integer ' PositionX
posy as integer ' PositionY
gadw as integer ' Gadget Breite (Containerbreite)
gadh as integer ' Gadget Höhe (Containerhöhe)
gadtext as string ' Gadget Text
strbuff as string ' String Text Puffer
slpos as integer ' Knob Position in px (ergibt sich aus slval) Interval: 5 bis gadw-5 !!! gadw =Resolution(px)+9
slpot as ushort ' Potentiometer (ermittelt aus slpos) Interval: immer &H0 bis &HFFFF
end type
dim shared as Gadget GadgetList(1 to maxgad)
'GadgetTypen
const SimpleGadget=1 'StandardGadget (p+r)
const TextOptionGadget=2 'TextOptionGadget (r)
const HTrackbar=10 'HTrackbar (p)
'GadgetModus 1= visible unselect
' 2= visible select
' 3= locked visible
' 0= locked invisible
'reply 1= Antwort von GadgetControl bei Press
' 2= Antwort von GadgetControl bei Release
' 3= Antwort von GadgetControl bei beiden
' (ansonsten liefert sie -1)
'main sub
declare function GadgetControl (mevent as integer,mx as integer,my as integer) as integer
declare sub ModifyPress(gadnum as integer,mx as integer,my as integer)
declare sub ModifyRelease(gadnum as integer,mx as integer,my as integer)
declare sub DrawGadget (gadnum as integer)
'Hilfsfunktionen für alle Gadgets
declare function GetGadgetNumber(mx as integer,my as integer) as integer
declare function GetGadgetMode (gadnum as integer) as integer
declare sub SetGadgetMode (gadnum as integer,mode as integer)
declare sub ChangeGadgetMode (gadnum as integer,mode as integer)
declare function GetGadgetReply (gadnum as integer) as integer
'Font
declare function GetFontHeight as integer
'Simple und TextOption
declare sub AddSimpleGadget (gadnum as integer,x as integer,y as integer,w as integer,h as integer,txt as string)
declare sub AddTextOptionGadget (gadnum as integer,x as integer,y as integer,w as integer,h as integer,txt as string)
declare sub gfxSimpleGadget (gadnum as integer)
'HTrackbar
declare sub AddHTrackbar (gadnum as integer,x as integer,y as integer,res as integer)
declare sub gfxHTrackbar (gadnum as integer)
declare sub SetPos(gadnum as integer,p as integer)
declare sub SetPot (gadnum as integer,p as ushort)
declare function GetPot (gadnum as integer) as ushort
'Farb Schema - global
dim shared as uinteger cblack,cwhite,cbackground,ccursor,colora,colorb,colorc,colord,colore,colorf
cbackground =&HF0F0F0 'Hintergrund
cblack =&H000000
cwhite =&HFFFFFF
ccursor =&HDD8833
colora =&HEAEAEB 'unselect body oben
colorb =&HDCDCDC 'unselect body unten
colorc =&HDCF0FF 'select body oben
colord =&HB4D2FA 'select body unten
colore =&H959595 'border slider knob
colorf =&HE1E1E1 'border slider container
'******************************************************************************
'******************************************************************************
'Haupt Subs und Functions
function GadgetControl (mevent as integer,mx as integer,my as integer) as integer
dim as integer gadnum
static as integer remember,fallbackmode
gadnum=0
if mevent=1 or mevent=2 then
gadnum=GetGadgetNumber(mx,my)
if gadnum=-1 and remember=0 then remember=gadnum
if gadnum>0 and remember=0 then
remember=gadnum
fallbackmode=GetGadgetMode(gadnum)
end if
if remember>0 and gadnum=remember then
ModifyPress (gadnum,mx,my)
DrawGadget(gadnum)
if GetGadgetReply(gadnum)=2 then gadnum=0 ' bei 2 nur Relase als Antwort zugelassen
else
gadnum=0
end if
end if
if mevent=3 and remember<>0 then
gadnum=GetGadgetNumber(mx,my)
if remember>0 and gadnum<>remember then
SetGadgetMode(remember,fallbackmode)
DrawGadget(remember)
gadnum=-1
end if
if remember>0 and gadnum=remember then
ModifyRelease (gadnum,mx,my)
DrawGadget(gadnum)
if GetGadgetReply(gadnum)=1 then gadnum=0 ' bei 1 nur Press als Antwort zugelassen
end if
if remember=-1 then gadnum=-1
remember=0
fallbackmode=0
end if
function=gadnum
end function
'Wie soll das Gadget bei Press verändert werden
'verändert werden nur bestimmte GadgetList()records des Gadgets!
'jede Typennummer kann dabei seine eigene Routine haben
'diese Sub muss entsprechend neuer Gadgets erweitert werden
sub ModifyPress (gadnum as integer,mx as integer,my as integer)
select case GadgetList(gadnum).gadtype
case SimpleGadget
SetGadgetMode (gadnum,2)
case TextOptionGadget
'there's nothing to do
case HTrackbar
SetPos(gadnum,mx- GadgetList(gadnum).posx)
SetGadgetMode (gadnum,2)
end select
end sub
'Wie soll das Gadget bei Release verändert werden
'verändert werden nur bestimmte GadgetList()records des Gadgets
'jede Typennummer kann dabei seine eigene Routine haben
'diese Sub muss entsprechend neuer Gadgets erweitert werden
sub ModifyRelease (gadnum as integer,mx as integer,my as integer)
select case GadgetList(gadnum).gadtype
case SimpleGadget
SetGadgetMode(gadnum,1)
case TextOptionGadget
if GetGadgetMode(gadnum)=1 then SetGadgetMode(gadnum,2) else SetGadgetMode(gadnum,1)
case HTrackbar
SetGadgetMode(gadnum,1)
end select
end sub
'Zeichnet das Gadget
'und gleichzeitig Zuordnung der gfxSubs zur entsprechenden Typnummer
'diese Sub muss entsprechend neuer Gadgets erweitert werden
sub DrawGadget(gadnum as integer)
select case GadgetList(gadnum).gadtype
case SimpleGadget,TextOptionGadget
gfxSimpleGadget(gadnum)
case HTrackbar
gfxHTrackbar(gadnum)
end select
end sub
'******************************************************************************
'******************************************************************************
'Hilfsfunktionen und Subs für alle Gadgets
function GetGadgetNumber(mx as integer,my as integer) as integer
dim as integer i,gadnum
gadnum=-1
for i=1 to maxgad
if GadgetList(i).mode=1 or GadgetList(i).mode=2 then 'nur mode 1,2 liefert etwas, ansonst 0
if mx>=GadgetList(i).posx and mx<GadgetList(i).posx+GadgetList(i).gadw and _
my>=GadgetList(i).posy and my<GadgetList(i).posy+GadgetList(i).gadh then gadnum=i
end if
next i
function=gadnum
end function
function GetGadgetMode (gadnum as integer) as integer
function=GadgetList(gadnum).mode
end function
sub SetGadgetMode (gadnum as integer,mode as integer)
GadgetList(gadnum).mode=mode
end sub
sub ChangeGadgetMode (gadnum as integer,mode as integer)
GadgetList(gadnum).mode=mode
DrawGadget(gadnum)
end sub
function GetGadgetReply (gadnum as integer) as integer
Function=GadgetList(gadnum).reply
end function
'******************************************************************************
'******************************************************************************
'Font
function GetFontHeight as integer
dim as integer depth,fheight,i,col
dim as integer ptr gfx
SCREENINFO ,,depth
gfx=imagecreate(16,32)
if gfx then
select case depth
case 16,32
color &HFFFFFF,&H000000
line gfx,(0,0)-(15,31),&HFFFFFF,bf
draw string gfx,(0,0),chr(219),&H000000
col=&H000000
case 8
color 1,2
line gfx,(0,0)-(15,31),1,bf
draw string gfx,(0,0),chr(219),2
col=2
end select
for i=0 to 32
if point(0,i,gfx)=col then fheight=i
next i
imagedestroy (gfx)
end if
fheight +=1
function=fheight
end function
'GADGETS Adds und gfx
'====================
'******************************************************************************
'******************************************************************************
'Simple und TextOption Gadget
sub AddSimpleGadget (gadnum as integer,x as integer,y as integer,w as integer,h as integer,txt as string)
GadgetList(gadnum).gadtype=SimpleGadget
GadgetList(gadnum).mode=0
GadgetList(gadnum).reply=2
GadgetList(gadnum).posx=x
GadgetList(gadnum).posy=y
GadgetList(gadnum).gadw=w
GadgetList(gadnum).gadh=h
GadgetList(gadnum).gadtext=txt
end sub
sub AddTextOptionGadget (gadnum as integer,x as integer,y as integer,w as integer,h as integer,txt as string)
GadgetList(gadnum).gadtype=TextOptionGadget
GadgetList(gadnum).mode=0
GadgetList(gadnum).reply=2
GadgetList(gadnum).posx=x
GadgetList(gadnum).posy=y
GadgetList(gadnum).gadw=w
GadgetList(gadnum).gadh=h
GadgetList(gadnum).gadtext=txt
end sub
sub gfxSimpleGadget (gadnum as integer)
dim as uinteger txtcolor,bodya,bodyb,edge_tl,edge_br,border
dim as integer x,y,w,h
x =GadgetList(gadnum).posx
y =GadgetList(gadnum).posy
w =GadgetList(gadnum).gadw
h =GadgetList(gadnum).gadh
select case GadgetList(gadnum).mode
case 0
txtcolor=cbackground
bodya=cbackground
bodyb=cbackground
edge_tl=cbackground
edge_br=cbackground
border=cbackground
case 1
txtcolor=cblack
bodya=colora
bodyb=colorb
edge_tl=colora
edge_br=colora
border=colore
case 2
txtcolor=cblack
bodya=colorc
bodyb=colord
edge_tl=colord
edge_br=colord
border=colore
case 3
txtcolor=colore
bodya=colora
bodyb=colora
edge_tl=colora
edge_br=colora
border=colore
end select
line (x+2,y+2)-(x+w-3,y+h/2),bodya,bf
line (x+2,y+h/2)-(x+w-3,y+h-3),bodyb,bf
draw string ( x+(w-len(GadgetList(gadnum).gadtext)*8)/2 , y+(h-fontheight)/2 ),GadgetList(gadnum).gadtext,txtcolor
line (x+2,y+1)-(x+w-3,y+1),edge_tl
line (x+1,y+2)-(x+1,y+h-3),edge_tl
line (x+2,y+h-2)-(x+w-3,y+h-2),edge_br
line (x+w-2,y+2)-(x+w-2,y+h-3),edge_br
line (x+1,y)-(x+w-2,y),border
line -(x+w-2,y+1),border
line -(x+w-1,y+1),border
line -(x+w-1,y+h-2),border
line -(x+w-2,y+h-2),border
line -(x+w-2,y+h-1),border
line -(x+1,y+h-1),border
line -(x+1,y+h-2),border
line -(x,y+h-2),border
line -(x,y+1),border
line -(x+1,y+1),border
end sub
'******************************************************************************
'******************************************************************************
'HTrackbar
sub AddHTrackbar (gadnum as integer,x as integer,y as integer,res as integer)
GadgetList(gadnum).gadtype=HTrackbar
GadgetList(gadnum).mode=0
GadgetList(gadnum).reply=1
GadgetList(gadnum).posx=x
GadgetList(gadnum).posy=y
GadgetList(gadnum).gadw=res+9
GadgetList(gadnum).gadh=22
end sub
sub gfxHTrackbar (gadnum as integer)
dim as uinteger border,bodya,bodyb,slota,slotb,slotc
dim as integer x,y,w,h,p
select case GadgetList(gadnum).mode
case 0
border=cbackground
bodya=cbackground
bodyb=cbackground
slota=cbackground
slotb=cbackground
slotc=cbackground
case 1
border=colore
bodya=colora
bodyb=colorb
slota=colore
slotb=colorb
slotc=cwhite
case 2
border=colore
bodya=colorc
bodyb=colord
slota=colore
slotb=colorb
slotc=cwhite
case 3
border=colorf
bodya=colora
bodyb=colora
slota=colora
slotb=colora
slotc=cwhite
end select
x =GadgetList(gadnum).posx
y =GadgetList(gadnum).posy
w =GadgetList(gadnum).gadw
h =GadgetList(gadnum).gadh
p =GadgetList(gadnum).slpos
'clear
line (x,y) -(x+p-6,y+8),cbackground,bf
line (x,y+13)-(x+p-6,y+h-1),cbackground,bf
line (x+p+5,y) -(x+w-1,y+8),cbackground,bf
line (x+p+5,y+13)-(x+w-1,y+h-1),cbackground,bf
'slot
line (x,y+9)-(x+p-5,y+9),slota
line (x,y+10)-(x,y+11),slota
line (x+1,y+10)-(x+p-5,y+11),slotb,bf
line (x,y+12)-(x+p-5,y+12),slotc
line (x+p+4,y+9)-(x+w-1,y+9),slota
line (x+p+4,y+10)-(x+w-1,y+11),slotb,bf
line (x+p+4,y+12)-(x+w-1,y+12),slotc
line (x+w-1,y+11)-(x+w-1,y+12),slotc
'knob 11x22px Bewgung von 5 bis gadw-5
line (x+p-5,y) -(x+p+4,y+h-1),border,b
line (x+p-4,y+1) -(x+p+3,y+h/2),bodya,bf
line (x+p-4,y+h/2)-(x+p+3,y+h-2),bodyb,bf
end sub
sub SetPos(gadnum as integer,p as integer)
if p<5 then p=5
if p>GadgetList(gadnum).gadw-5 then p=GadgetList(gadnum).gadw-5
GadgetList(gadnum).slpos=p
GadgetList(gadnum).slpot=cast (ushort,&HFFFF * (GadgetList(gadnum).slpos-5) / (GadgetList(gadnum).gadw-10) )
end sub
sub SetPot (gadnum as integer,p as ushort)
GadgetList(gadnum).slpot=p
GadgetList(gadnum).slpos=(GadgetList(gadnum).slpot/&HFFFF*(GadgetList(gadnum).gadw-10))+5
end sub
function GetPot (gadnum as integer) as ushort
function=GadgetList(gadnum).slpot
end function
'##############################################################################
'##############################################################################
'End SimpleGUI.bi