Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
CSE
| Uploader: |  csde_rats |
| Datum/Zeit: | 16.11.2007 14:39:55 |
#Include "fbgfx.bi"
#Define PageNum 4
#Define FS 0
#If FS = 1
#Define ScreenMode fb.GFX_FULLSCREEN
#Else
#Define ScreenMode
#EndIf
#Define rs_800x600 Screen 19, 32, PageNum, ScreenMode, 60
#Define rows_80x50 Width 80, 50
#Define xwid 80
' Texte
#Define ces "CheckEuroSerial"
#Define search "Suche"
#Define sFound "Seriennummer gefunden!"
#Define RGBSame(x) RGB(x , x , x )
' Farben
#Define White RGB(255, 255, 255)
#Define Grey200 RGBSame(200 )
#Define Grey150 RGBSame(150 )
#Define Grey100 RGBSame(100 )
#Define Grey50 RGBSame(50 )
#Define Black RGB(0 , 0 , 0 )
#Define Red RGB(255, 0 , 0 )
#Define Green RGB(0 , 255, 0 )
#Define Blue RGB(0 , 0 , 255)
#Define Yellow RGB(255, 255, 0 )
#Define Tuerkese RGB(0 , 255, 255)
#Define Lila RGB(255, 0 , 255)
' Style
#Define Title_Active Blue
#Define Title_InActive Tuerkese
#Define Title_Active_Font White
#Define Title_InActive_Font Black
#Define Font_Color Yellow
Dim Shared TrmInt As Integer = 0
Function MakeImage(x As Integer, y As Integer) As Any Ptr
Dim img As Any Ptr
img=ImageCreate(x,y)
Line img, (0,0)-(x,y), Black, BF
Return img
End Function
' Term() Funktion
#Define Term() TrmInt = 1: End
#Macro ScreenInit()
rs_800x600
rows_80x50
WindowTitle ces
#EndMacro
#Macro DoSearch()
Dim found As Integer=0
For n As Integer = LBound(sSerialNums) To UBound(sSerialNums)
If sSerialNums(n) = sSerialInput Then found = 1: Exit For
Next
'Draw String (10,500), sFound, Green
#EndMacro
' Aufgabe: Benutztereingaben verarbeiten
Type CheckObjects
Declare Sub CheckObject_Mouse()
Declare Sub CheckObject_Vars()
Declare Sub CheckObject_X()
Declare Sub CheckObject_Input()
Declare Sub CheckObject_Search()
Public:
ToSearch As Integer=0
ToInput As Integer=0
Input As String
Private:
x As Integer ' X Koordinate der Maus
y As Integer ' Y Koordinate der Maus
b As Integer ' Welche Mausbuttons sind gedrückt?
ToTerm As Integer ' Programmterminierungssignal
End Type
Sub CheckObjects.CheckObject_Mouse()
GetMouse(x, y, 0, b)
End Sub
Sub CheckObjects.CheckObject_Vars()
If this.ToTerm = 1 Then Term()
End Sub
Sub CheckObjects.CheckObject_X()
If x>=784 And x<=798 And y>=2 And y<=18 And Bit(b, 0) Then this.ToTerm = 1
End Sub
Sub CheckObjects.CheckObject_Input()
If x>=30 And x<=630 And y>=30 And y<=48 And Bit(b, 0) Then this.ToInput = 1
End Sub
Sub CheckObjects.CheckObject_Search()
If x>=650 And x<=783 And y>=30 And y<=48 And Bit(b, 0) Then this.ToSearch = 1
End Sub
' Aufgabe: Objekte zeichnen
Type PaintObjects
Declare Constructor()
Declare Destructor()
Declare Sub DrawObject_WinBrder()
Declare Sub DrawObject_X()
Declare Sub DrawObject_Input()
Declare Sub DrawObject_SearchButton()
Declare Sub DrawObject_List()
Public:
atx As Integer
aty As Integer
Private:
Object_CloseButton As Any Ptr
Object_InputBox As Any Ptr
Object_SearchButton As Any Ptr
Object_List As Any Ptr
End Type
Constructor PaintObjects()
Object_CloseButton=MakeImage(16, 16)
Object_InputBox=MakeImage(623, 20)
Object_SearchButton=MakeImage(134, 20)
Object_List=MakeImage(774, 531)
End Constructor
Destructor PaintObjects()
ImageDestroy(Object_CloseButton)
ImageDestroy(Object_InputBox)
ImageDestroy(Object_SearchButton)
ImageDestroy(Object_List)
End Destructor
Sub PaintObjects.DrawObject_WinBrder()
Line(0,0)-(800,18), Title_Active, BF
Draw String (2,2), ces, Title_Active_Font
End Sub
Sub PaintObjects.DrawObject_X()
Line Object_CloseButton, (0,0)-(15,15), White, B
Line Object_CloseButton, (4,4)-(12,12), White
Line Object_CloseButton, (4,12)-(12,4), White
Put((800-16)-1, 1), Object_CloseButton, PSet
End Sub
Sub PaintObjects.DrawObject_Input()
Line Object_InputBox, (3,3)-(623, 20), White, B
Line Object_InputBox, (2,2)-(622, 19), Grey200, B
Line Object_InputBox, (1,1)-(621, 18), Grey150, B
Put(atx, aty), Object_InputBox, PSet
End Sub
Sub PaintObjects.DrawObject_SearchButton()
Line Object_SearchButton, (3,3)-(133,20), White, B
Line Object_SearchButton, (2,2)-(132,19), Grey200, B
Line Object_SearchButton, (1,1)-(131,18), Grey150, B
Draw String Object_SearchButton, ((65-Len(search)*8/2),4), search, Font_Color
Put(atx, aty), Object_SearchButton, PSet
End Sub
Sub PaintObjects.DrawObject_List()
Line Object_List, (3,3)-(773,530), White, B
Line Object_List, (2,2)-(772,529), Grey200, B
Line Object_List, (1,1)-(771,528), Grey150, B
Put(atx, aty), Object_List, PSet
End Sub
' Aufgabe: Hauptprogramm
Type main
Declare Function method() As Integer
Private:
returnvalue As Integer
End Type
Sub WatchDog(th As Any Ptr)
Dim ChObj As CheckObjects
Do Until TrmInt = 1
Sleep 50
With ChObj
.CheckObject_Mouse()
.CheckObject_Vars()
.CheckObject_X()
End With
Loop
End Sub
Function main.method() As Integer
ScreenInit()
Dim PaObj As PaintObjects
Dim ChObj As CheckObjects
With PaObj
.DrawObject_WinBrder()
.DrawObject_X()
.atx = 10
.aty = 30
.DrawObject_Input()
.atx = 650
.aty = 30
.DrawObject_SearchButton()
.atx = 10
.aty = 60
.DrawObject_List()
End With
Dim wdThread As Any Ptr
wdThread=ThreadCreate(Procptr(WatchDog), 0)
Dim sSerialNums(0 To 25) As String
Dim sOwners(0 To 25) As String
Dim sSerialInput As String
Dim iLines As Integer
Dim sString As String
Draw String (15, 64), "Seriennummer:", Font_Color
Draw String (450, 64), "Besitzer:", Font_Color
Open "nums.txt" For Input As #1
Do Until Eof(1)
iLines+=1
Line Input #1, sString
For n As Integer = 0 To Len(sString)
If Mid(sString, n, 1) = ";" Then
sSerialNums(iLines) = Left(sString, n-1)
sOwners(iLines) = Right(sString, n-11)
EndIf
Next
Draw String (15, iLines*16+64), sSerialNums(iLines), Font_Color
Draw String (450, iLines*16+64), sOwners(iLines), Font_Color
Loop
Close #1
Dim found As Integer=0
Dim Taste As String * 1
Dim Inpt As String
Dim sSeriNum As String * 12 ' Seriennummern haben 13 Stellen (12 Numerische + 1 Alpha)
Do
Sleep 50
With ChObj
.CheckObject_Mouse()
.CheckObject_Vars()
.CheckObject_Input()
.CheckObject_Search()
If .ToSearch = 1 Then
For n As Integer = LBound(sSerialNums) To UBound(sSerialNums)
If sSerialNums(n) = sSerialInput Then
Beep(): Beep(): Beep()
Line(14, n*16+64)-(590, n*16+64+16), Red, B
Exit For
EndIf
Next
EndIf
End With
If ChObj.ToInput = 1 Then
Do
Taste=InKey()
If Taste<>"" Then
Select Case Asc(Taste)
Case 27, 13 ' Esc + Enter
Exit Do
Case 8 ' Backspace
If Len(Inpt) > 0 Then Inpt = Left(Inpt, Len(Inpt)-1)
Case Else
If Len(Inpt) > Len(sSeriNum) Then Beep(): Exit Do
Inpt += Taste
End Select
EndIf
Line (15, 34)-(629,47), Black, BF ' Inhalt löschen
Draw String (15, 34), Inpt, Font_Color, , PSet ' Inhalt neuschreiben
Sleep 50
Loop
EndIf
Loop
this.returnvalue=0
Return 0
End Function
Dim proc As main
End proc.method()