Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
InputThread
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 31.07.2007 08:49:18 |
'-ThreadWork:---------------------------------------------------------------------------'
Declare Function ThreadWork_holder (Byval handle As Any Ptr=0, Byval mode As Integer=0) As Any Ptr
Declare Sub ThreadWork_init
Declare Sub ThreadWork_Lock
Declare Sub ThreadWork_UnLock
Declare Sub ThreadWork_close
Declare Function ThreadWork_status As Integer
'---------------------------------------------------------------------------------------'
ThreadWork:
'---------------------------------------------------------------------------------------'
'****************************************************************
Sub ThreadWork_init
Dim ThreadWorkWait As Any Ptr
ThreadWorkWait=Mutexcreate
If Not ThreadWork_holder Then ThreadWork_holder (ThreadWorkWait,1)
End Sub
'****************************************************************
'****************************************************************
Function ThreadWork_holder (Byval handle As Any Ptr=0, _
Byval mode As Integer=0) As Any Ptr
Static ThreadWorkWait As Any Ptr
Select Case mode
Case 0
Return ThreadWorkWait
Case 1
ThreadWorkWait=handle
Return 0
End Select
End Function
'****************************************************************
'****************************************************************
Sub ThreadWork_Lock
Mutexlock ThreadWork_holder
End Sub
'****************************************************************
'****************************************************************
Sub ThreadWork_UnLock
Mutexunlock ThreadWork_holder
End Sub
'****************************************************************
'****************************************************************
Sub ThreadWork_close
Mutexdestroy ThreadWork_holder
ThreadWork_holder (0,1)
End Sub
'****************************************************************
'****************************************************************
Function ThreadWork_status As Integer
If ThreadWork_holder Then
Return -1
Else
Return 0
End If
End Function
'****************************************************************
'---------------------------------------------------------------------------------------'
'-InterfaceInput:-----------------------------------------------------------------------'
Declare Sub InputThread (Byref NULL As Integer)
'---------------------------------------------------------------------------------------'
Randomize Timer
Const ScrWidth=80 'Bildschirmbreite in Zeichen
Const ScrHeight=30 'Bildschirmhoehe in Zeichen
Width ScrWidth,ScrHeight
ThreadWork_init
Dim Eingabe As Any Ptr
Eingabe=Threadcreate(@InputThread,0)
Do
Sleep (50)
Loop Until Multikey(&h01)
ThreadWork_close
Threadwait (Eingabe)
End
InterfaceInput:
'---------------------------------------------------------------------------------------'
'****************************************************************
Sub InputThread (Byref NULL As Integer)
''' Kann man durch const/define/UDT ersetzen!!
''' Es dient jedoch der besseren Uebersicht der einzelnen Funktionen,
''' Und Ihrer Variablen.
''' ("Diese Variablen dienen ausschliesslich dieser !Angepassten! (Thread)Funktion.")
Dim inputmaxlen As Integer=450 'Eingabe ist auf 450 Zeichen beschraenkt
Dim StartX As Integer=1 'X Startposition der Eingabe
Dim StartY As Integer=ScrHeight'Y Startposition der Eingabe
Dim FeedLen As Integer=ScrWidth 'Sichtbare zeichenlaenge
Dim FontColor As Integer=0 'Schriftfarbe
Dim BackColor As Integer=15 'Hintergrundfarbe
''' Aus diesem Grund stehen sie hier...
FeedLen=Iif(FeedLen>ScrWidth,ScrWidth,FeedLen)
Dim key As String
Dim cursor As Integer=1
Dim inputstring As String
Dim ViewString As String
Dim VCursor As Integer
Dim SS As Integer
Dim SE As Integer
ThreadWork_lock
Color FontColor,BackColor
Locate StartY,StartX,0:?Space(FeedLen);
Color 0,7
Locate StartY,StartX,0:?Chr(32);
ThreadWork_unlock
Do
key=Inkey
If Len(key) Then
Select Case Key
'----------------------------'
Case Chr(8) 'BackSpace
If Len(inputstring) And (Cursor > 1) Then
inputstring = Left(inputstring, Cursor - 2) + Right(inputstring, Len(inputstring) - Cursor + 1)
If Cursor>1 Then Cursor -= 1
End If
'----------------------------'
Case Chr(255,83) 'Del
If (Cursor <= Len(inputstring)) Then
inputstring = Left(inputstring, Cursor - 1) + Right(inputstring, Len(inputstring) - Cursor)
End If
'----------------------------'
Case Chr(13) 'Enter
'''' ''''
'' Hier soll die eingabe einer verarbeitungs-routine uebergeben werden ''
'''' ''''
inputstring=""
'----------------------------'
Case Chr(27) 'ESC
inputstring=""
'----------------------------'
Case Chr(255, 75) 'Left
If Cursor > 1 Then Cursor -= 1
'----------------------------'
Case Chr(255, 77) 'Right
If Cursor And (Cursor <= Len(inputstring)) Then Cursor += 1
'----------------------------'
Case Chr(255, 71) 'Pos1
If Cursor Then Cursor = 1
'----------------------------'
Case Chr(255, 79) 'End
If Cursor Then Cursor = Len(inputstring)+1
Case Else
If ( Len(inputstring) < inputmaxlen ) Then
inputstring = Left(inputstring, Cursor - 1) + Key + Right(inputstring, Len(inputstring) - (Cursor-1) )
Cursor += 1
End If
End Select
SS=Cursor-(FeedLen-1)
SS=Iif(SS<1,1,SS)
SE=SS+(FeedLen-1)
SE=Iif(SE>Len(inputstring),Len(inputstring),SE)
ViewString=Mid(inputstring,SS,1+(SE-SS))
VCursor=Iif(SS>1,Cursor-(SS-1),Cursor)
ThreadWork_lock
Color FontColor,BackColor
Locate StartY,StartX,0:?Space(FeedLen);
Locate StartY,StartX,0:?ViewString;
If SS>1 And VCursor>4 Then Locate StartY,StartX,0:?"...<<";
If SE<Len(inputstring) And VCursor<(FeedLen-4) Then Locate StartY,(StartX+FeedLen)-5,0:?">>...";
Color 0,7
Locate StartY,(StartX-1)+VCursor,0:?Chr(Screen (StartY, (StartX-1)+VCursor, 0));
ThreadWork_unlock
End If
Sleep (5)
Loop While ThreadWork_status
End Sub
'****************************************************************