Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
cse³
| Uploader: |  csde_rats |
| Datum/Zeit: | 26.11.2007 23:23:57 |
#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
' 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(this.x, this.y, 0, this.b)
End Sub
Sub CheckObjects.CheckObject_Vars()
If this.ToTerm = 1 Then Term()
End Sub
Sub CheckObjects.CheckObject_X()
If this.x>=784 And this.x<=798 And this.y>=2 And this.y<=18 And Bit(this.b, 0) Then this.ToTerm = 1
End Sub
Sub CheckObjects.CheckObject_Input()
If this.x>=30 And this.x<=630 And this.y>=30 And this.y<=48 And Bit(this.b, 0) Then this.ToInput = 1
End Sub
Sub CheckObjects.CheckObject_Search()
If this.x>=650 And this.x<=783 And this.y>=30 And this.y<=48 And Bit(this.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()
this.Object_CloseButton=MakeImage(16, 16)
this.Object_InputBox=MakeImage(623, 20)
this.Object_SearchButton=MakeImage(134, 20)
this.Object_List=MakeImage(774, 531)
End Constructor
Destructor PaintObjects()
ImageDestroy(this.Object_CloseButton)
ImageDestroy(this.Object_InputBox)
ImageDestroy(this.Object_SearchButton)
ImageDestroy(this.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 this.Object_CloseButton, (0,0)-(15,15), White, B
Line this.Object_CloseButton, (4,4)-(12,12), White
Line this.Object_CloseButton, (4,12)-(12,4), White
Put((800-16)-1, 1), this.Object_CloseButton, PSet
End Sub
Sub PaintObjects.DrawObject_Input()
Line this.Object_InputBox, (3,3)-(623, 20), White, B
Line this.Object_InputBox, (2,2)-(622, 19), Grey200, B
Line this.Object_InputBox, (1,1)-(621, 18), Grey150, B
Put(atx, aty), this.Object_InputBox, PSet
End Sub
Sub PaintObjects.DrawObject_SearchButton()
Line this.Object_SearchButton, (3,3)-(133,20), White, B
Line this.Object_SearchButton, (2,2)-(132,19), Grey200, B
Line this.Object_SearchButton, (1,1)-(131,18), Grey150, B
Draw String this.Object_SearchButton, ((65-Len(search)*8/2),4), search, Font_Color
Put(atx, aty), this.Object_SearchButton, PSet
End Sub
Sub PaintObjects.DrawObject_List()
Line this.Object_List, (3,3)-(773,530), White, B
Line this.Object_List, (2,2)-(772,529), Grey200, B
Line this.Object_List, (1,1)-(771,528), Grey150, B
Put(atx, aty), this.Object_List, PSet
End Sub
' Aufgabe: Hauptprogramm
Type main
Declare Function method() As Integer
Private:
returnvalue As Integer
End Type
Sub WatchDog(th As CheckObjects Ptr)
Dim ChObj As CheckObjects
Do Until TrmInt = 1
Sleep 50
th->CheckObject_Mouse()
th->CheckObject_Vars()
th->CheckObject_X()
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), Cast(Any Ptr, VarPtr(ChObj)))
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_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()