Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Kleines Gui beispiel
| Uploader: |  XOR |
| Datum/Zeit: | 05.07.2011 00:24:05 |
#Define Quit Inkey=Chr(255,107)
Type Mouse
Declare Sub Update ()
X As Integer
Y As Integer
W As Integer
B As Integer
Xa As Integer
Ya As Integer
Wa As Integer
Ba As Integer
End Type
Sub Mouse.Update ()
This.Xa = This.X
This.Ya = This.Y
This.Wa = This.W
This.Ba = This.B
GetMouse This.X, This.Y, This.W, This.B
If This.X = -1 Or This.Y = -1 Then
This.X = This.Xa
This.Y = This.Ya
This.W = This.Wa
This.B = This.Ba
EndIf
End Sub
Type WinRect
X As Integer
Y As Integer
W As Integer
H As Integer
End Type
Type Gadget
Parent As Gadget Ptr
ChildFirst As Gadget Ptr
ChildLast As Gadget Ptr
NextGadget As Gadget Ptr
PrevGadget As Gadget Ptr
IsChild:1 As Integer
OnState:2 As Integer
State:2 As Integer
WinType:27 As Integer
Text As ZString Ptr
R As WinRect
F As WinRect
DrawGadget As Sub ( ByVal As Gadget Ptr, ByVal As Integer, ByVal As Integer )
MouseOver As Function ( ByVal As Gadget Ptr, ByVal As Integer, ByVal As Integer, ByVal As Mouse Ptr ) As Integer
MouseFunc As Sub ( ByVal As Gadget Ptr, ByVal As Integer, ByVal As Integer, ByVal As Mouse Ptr )
CallBackFunc As Sub ( ByVal As Gadget Ptr )
End Type
Dim Shared LastSelWin As Gadget Ptr
Function GFXAddColor ( ByVal C As UInteger, ByVal W As Integer ) As UInteger
Dim As Integer R,G,B
R = HiByte(LoWord(C))
G = LoByte(HiWord(C))
B = LoByte(LoWord(C))
R += W
G += W
B += W
If R < 0 Then R = 0
If R > 255 Then R = 255
If G < 0 Then G = 0
If G > 255 Then G = 255
If B < 0 Then B = 0
If B > 255 Then B = 255
Return RGB(R,G,B)
End Function
Sub DrawBox1 ( ByVal C As UInteger, ByVal R As WinRect, ByVal S As Integer )
If S=0 Then
For i As Integer = 0 To R.H
Line (R.X,R.Y+i)-(R.X+R.W,R.Y+i),GFXAddColor(C,(-i/R.H+0.5)*60),bf
Next
Else
For i As Integer = 0 To R.H
Line (R.X,R.Y+i)-(R.X+R.W,R.Y+i),GFXAddColor(C,(i/R.H-0.5)*60),bf
Next
EndIf
End Sub
Function MouseOverOp ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer, ByVal M As Mouse Ptr ) As Integer
If X <= M->X And X+G->R.W+G->F.X+G->F.W >= M->X And Y <= M->Y And Y+G->R.H+G->F.Y+G->F.H >= M->Y Then
Return -1
EndIf
Return 0
End Function
Sub GadgetToTop ( ByVal G As Gadget Ptr )
If G->Parent=0 Then Exit Sub
If G->Parent->ChildLast = G Then Exit Sub
If G->NextGadget Then
G->NextGadget->PrevGadget = G->PrevGadget
EndIf
If G->PrevGadget Then
G->PrevGadget->NextGadget = G->NextGadget
Else
G->Parent->ChildFirst = G->NextGadget
EndIf
G->NextGadget = 0
G->Parent->ChildLast->NextGadget = G
G->PrevGadget = G->Parent->ChildLast
G->Parent->ChildLast = G
End Sub
Sub GadgetToBottom ( ByVal G As Gadget Ptr )
If G->Parent=0 Then Exit Sub
If G->Parent->ChildFirst = G Then Exit Sub
If G->NextGadget Then
G->NextGadget->PrevGadget = G->PrevGadget
Else
G->Parent->ChildLast = G->PrevGadget
EndIf
If G->PrevGadget Then
G->PrevGadget->NextGadget = G->NextGadget
EndIf
G->PrevGadget = 0
G->Parent->ChildFirst->PrevGadget = G
G->NextGadget = G->Parent->ChildFirst
G->Parent->ChildFirst = G
End Sub
Sub DrawGadgetGui ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer )
Dim C As Gadget Ptr
If G->OnState = 0 Then Exit Sub
If G->IsChild Then
X += G->R.X
Y += G->R.Y
Else
X = G->R.X
Y = G->R.Y
EndIf
If G->DrawGadget Then G->DrawGadget(G,X,Y)
X += G->F.X
Y += G->F.Y
C = G->ChildFirst
Do Until C = 0
If C->IsChild then DrawGadgetGui(C,X,Y)
C = C->NextGadget
Loop
C = G->ChildFirst
Do Until C = 0
If C->IsChild=0 Then DrawGadgetGui(C,X,Y)
C = C->NextGadget
Loop
End Sub
Sub DesktopDrawUpdate ( ByVal G As Gadget Ptr )
DrawGadgetGui(G,0,0)
End Sub
Function MouseUpdateGui ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer, ByVal M As Mouse Ptr ) As Integer
Dim C As Gadget Ptr
If M = 0 Then Return 0
If G->OnState <> 1 Then Return 0
If G->IsChild Then
X += G->R.X
Y += G->R.Y
Else
X = G->R.X
Y = G->R.Y
EndIf
If G->MouseOver = 0 Then Return 0
If G->MouseOver(G,X,Y,M) = 0 Then Return 0
GadgetToTop(G)
LastSelWin = G
X += G->F.X
Y += G->F.Y
C = G->ChildLast
Do Until C = 0
If MouseUpdateGui(C,X,Y,M) Then Exit Do
C = C->PrevGadget
Loop
Return -1
End Function
Function DesktopMouseUpdate ( ByVal G As Gadget Ptr, ByVal M As Mouse Ptr ) As Integer
Dim C As Gadget Ptr
Function = 0
If M->B = 1 And M->Ba = 0 Then
C = G->ChildLast
LastSelWin = 0
Do Until C = 0
If MouseUpdateGui(C,0,0,M) Then
Function = -1
Exit Do
EndIf
C = C->PrevGadget
Loop
EndIf
If LastSelWin Then
Dim As Integer X,Y
Dim As Gadget Ptr P
X = LastSelWin->R.X
Y = LastSelWin->R.Y
P = LastSelWin
Do Until P->IsChild = 0
P = P->Parent
If P = 0 Then Exit Do
X += P->R.X+P->F.X
Y += P->R.Y+P->F.Y
Loop
LastSelWin->MouseFunc(LastSelWin,X,Y,M)
EndIf
Return 0
End Function
Function CreateGadget ( ByVal P As Gadget Ptr, ByVal IsChild As Integer, ByVal Text As String, ByVal X As Integer, ByVal Y As Integer, ByVal W As Integer, ByVal H As Integer, ByVal T As Integer, ByVal DrawGadget As Sub ( ByVal As Gadget Ptr, ByVal As Integer, ByVal As Integer ), ByVal MouseOver As Function ( ByVal As Gadget Ptr, ByVal As Integer, ByVal As Integer, ByVal As Mouse Ptr ) As Integer, ByVal MouseFunc As Sub ( ByVal As Gadget Ptr, ByVal As Integer, ByVal As Integer, ByVal As Mouse Ptr ), ByVal CallBackFunc As Sub ( ByVal As Gadget Ptr ) ) As Gadget Ptr
Dim NewGadget As Gadget Ptr
NewGadget = Allocate(SizeOf(Gadget))
For i As Integer = 0 To SizeOf(Gadget)-1
Cast(UByte Ptr,NewGadget)[i] = 0
Next
NewGadget->Parent = P
If P Then
If P->ChildFirst = 0 Then
P->ChildFirst = NewGadget
P->ChildLast = NewGadget
Else
P->ChildLast->NextGadget = NewGadget
NewGadget->PrevGadget = P->ChildLast
P->ChildLast = NewGadget
EndIf
EndIf
NewGadget->IsChild = IsChild
If Text = "" Then
NewGadget->Text = 0
Else
NewGadget->Text = Allocate(Len(Text)+1)
*NewGadget->Text = Text
EndIf
NewGadget->R.X = X
NewGadget->R.Y = Y
NewGadget->R.W = W
NewGadget->R.H = H
NewGadget->WinType = T
NewGadget->OnState = 1
NewGadget->DrawGadget = DrawGadget
NewGadget->MouseOver = IIf(MouseOver=0,@MouseOverOp,MouseOver)
NewGadget->MouseFunc = MouseFunc
NewGadget->CallBackFunc = CallBackFunc
Return NewGadget
End Function
Sub DestroyGadget ( ByVal G As Gadget Ptr )
If G->NextGadget Then
G->NextGadget->PrevGadget = G->PrevGadget
Else
If G->Parent Then
G->Parent->ChildLast = G->PrevGadget
EndIf
EndIf
If G->PrevGadget Then
G->PrevGadget->NextGadget = G->NextGadget
Else
If G->Parent Then
G->Parent->ChildFirst = G->NextGadget
EndIf
EndIf
Do Until G->ChildFirst = 0
DestroyGadget(G->ChildFirst)
Loop
If G->Text Then DeAllocate(G->Text)
DeAllocate(G)
End Sub
Sub GadgetOn ( ByVal G As Gadget Ptr )
G->OnState = 1
GadgetToTop(G)
End Sub
Sub GadgetOff ( ByVal G As Gadget Ptr )
If LastSelWin = G Then LastSelWin = 0
G->OnState = 0
GadgetToBottom(G)
End Sub
Sub GadgetSleep ( ByVal G As Gadget Ptr )
G->OnState = 2
GadgetToTop(G)
End Sub
Sub SetGadgetText ( ByVal G As Gadget Ptr, ByVal Text As String )
If G->Text Then DeAllocate(G->Text)
If Text = "" Then
G->Text = 0
Else
G->Text = Allocate(Len(Text)+1)
*G->Text = Text
EndIf
End Sub
Function GetGadgetText ( ByVal G As Gadget Ptr ) As String
Return *G->Text
End Function
Sub SetGadgetPosi ( ByVal G As Gadget Ptr, ByVal Posi As WinRect )
G->R = Posi
End Sub
Function GetGadgetPosi ( ByVal G As Gadget Ptr ) As WinRect
Return G->R
End Function
Function CreateDesktop () As Gadget Ptr
Dim As Integer W,H
ScreenInfo W,H
Return CreateGadget ( 0, 0, "", 0, 0, W, H, 0, 0, 0, 0, 0 )
End Function
Sub DrawWindow ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer )
Dim As Integer W,H,IsAk
Dim As String Text
Dim As WinRect R
R.X = X
R.Y = Y
W = G->R.W+G->F.X+G->F.W
H = G->R.H+G->F.Y+G->F.H
R.W = W
R.H = G->F.Y
IsAk = 0
If G->Parent Then
If G->Parent->ChildLast = G Then
IsAk = -1
Else
Dim C As Gadget Ptr
C = G->Parent->ChildLast
Do Until C->IsChild=0
C = C->PrevGadget
Loop
If C = G Then
IsAk = -1
EndIf
EndIf
EndIf
If IsAk Then
DrawBox1(RGB(200,200,100),R,0)
Else
DrawBox1(RGB(100,100,100),R,0)
EndIf
Line (X,Y+R.H)-(X+W,Y+H),RGB(220,220,220),bf
Line (X-1,Y-1)-(X+W+1,Y+H+1),RGB(0,0,0),b
Text = *G->Text
If Len(Text)*8 > W Then
Text = Left(Text,Len(Text)-1)
Do Until (Len(Text)+3)*8 < W
Text = Left(Text,Len(Text)-1)
Loop
Text += "..."
EndIf
Draw String (X+W/2-Len(Text)*4,Y+R.H/2-8),Text,RGB(0,0,0)
End Sub
Sub MouseFuncWindow ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer, ByVal M As Mouse Ptr )
If M->B = 1 And G->State = 3 Then
G->R.X += M->X-M->Xa
G->R.Y += M->Y-M->Ya
EndIf
If M->B = 1 And M->Ba = 0 Then
If M->Y <= Y+G->F.Y Then G->State = 3
EndIf
If M->B = 0 Then
G->State = 0
EndIf
End Sub
Function CreateWindow ( ByVal P As Gadget Ptr, ByVal Text As String, ByVal X As Integer, ByVal Y As Integer, ByVal W As Integer, ByVal H As Integer ) As Gadget Ptr
Dim Win As Gadget Ptr
Win = CreateGadget ( P, 0, Text, X, Y, W, H, 1, @DrawWindow, 0, @MouseFuncWindow, 0 )
Win->F.Y = 24
Return Win
End Function
Sub DrawLabel ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer )
Draw String (X,Y),*G->Text,RGB(0,0,0)
End Sub
Function CreateLabel ( ByVal P As Gadget Ptr, ByVal Text As String , ByVal X As Integer, ByVal Y As Integer ) As Gadget Ptr
Return CreateGadget ( P, 1, Text, X, Y, 0, 0, 2, @DrawLabel, 0, 0, 0 )
End Function
Sub DrawButton ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer )
Dim As String Text
Dim As WinRect R
R.X = X
R.Y = Y
R.W = G->R.W+G->F.X+G->F.W
R.H = G->R.H+G->F.Y+G->F.H
DrawBox1(RGB(200,200,200),R,G->State)
Line (X-1,Y-1)-(X+R.W+1,Y+R.H+1),RGB(0,0,0),b
Text = *G->Text
If Len(Text)*8 > R.W Then
Text = Left(Text,Len(Text)-1)
Do Until (Len(Text)+3)*8 < R.W
Text = Left(Text,Len(Text)-1)
Loop
Text += "..."
EndIf
Draw String (X+R.W/2-Len(Text)*4,Y+R.H/2-8),Text,RGB(0,0,0)
End Sub
Sub MouseFuncButton ( ByVal G As Gadget Ptr, ByVal X As Integer, ByVal Y As Integer, ByVal M As Mouse Ptr )
If M->B = 1 And M->Ba = 0 Then
G->State = 1
EndIf
If MouseOverOp(G,X,Y,M) = 0 Then G->State = 0
If M->B = 0 And G->State = 1 Then
G->State = 0
If G->CallBackFunc Then G->CallBackFunc(G)
EndIf
End Sub
Function CreateButton ( ByVal P As Gadget Ptr, ByVal Text As String, ByVal X As Integer, ByVal Y As Integer, ByVal W As Integer, ByVal H As Integer, ByVal F As Sub ( ByVal As Gadget Ptr ) ) As Gadget Ptr
Return CreateGadget ( P, 1, Text, X, Y, W, H, 3, @DrawButton, 0, @MouseFuncButton, F )
End Function
Dim Shared D As Gadget Ptr
Dim Shared W(0 To 2) As Gadget Ptr
Sub EndGui(ByVal G As Gadget Ptr )
DestroyGadget(D)
End
End Sub
Sub WinHide(ByVal G As Gadget Ptr )
GadgetOff(W(0))
End Sub
Sub WinShow(ByVal G As Gadget Ptr )
GadgetOn(W(0))
End Sub
ScreenRes 640,480,32
Width 640/8,480/16
Dim L(0 To 3) As Gadget Ptr
Dim B(0 To 4) As Gadget Ptr
Dim A As Single
Dim M As Mouse
D = CreateDesktop()
W(0) = CreateWindow(D,"Window1",10,10,300,200)
W(1) = CreateWindow(D,"MousePosi",150,150,100,70)
W(2) = CreateWindow(D,"Window2",200,20,500,300)
L(0) = CreateLabel(W(2),"Label1",10,10)
L(1) = CreateLabel(W(0),"Label2",20,20)
L(2) = CreateLabel(W(1),"MX:0",10,10)
L(3) = CreateLabel(W(1),"MY:0",10,30)
B(0) = CreateButton(W(0),"End",30,40,100,20,@EndGui)
B(1) = CreateButton(W(2),"Hide Window1",30,40,100,20,@WinHide)
B(2) = CreateButton(W(2),"Show Window1",30,70,100,20,@WinShow)
B(3) = CreateButton(W(0),"X",280,-21,17,17,@WinHide)
B(4) = CreateButton(D,"End",1,1,100,17,@EndGui)
Do
M.Update()
SetGadgetText(L(2),"MX:"+Str(M.X))
SetGadgetText(L(3),"MY:"+Str(M.Y))
DesktopMouseUpdate(D,@M)
ScreenLock
For i As Integer = 0 To 600
Line(0,i)-(800,i),GFXAddColor(RGB(0,128,255),(i/600-0.5)*50),bf
Next
DesktopDrawUpdate(D)
ScreenUnLock
Sleep 1,1
Loop Until MultiKey(1) Or Quit
DestroyGadget(D)