FreeBasic
Главная
Вход
Регистрация
Вторник, 15.10.2024, 15:04Приветствую Вас Гость | RSS
[ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
  • Страница 1 из 1
  • 1
опрос клавиатуры
ntvgjhfnjДата: Четверг, 06.07.2023, 08:36 | Сообщение # 1
Лейтенант
Группа: Проверенные
Сообщений: 61
Репутация: 1
Статус: Offline
Жуткая задержка при опросе клавиатуры ...

Код


Dim Shared As Integer mx, my, mz, mb, omb
Dim Shared As String key, s, s2, ok

Sub se()
    Var key_ = InKey
    Select Case Asc(key_)
  Case 32 To 255
  s += key_
    End Select
    
End Sub

'
ScreenRes 800, 600, 32, 2
ScreenSet 1, 0
Color RGB(255, 128, 0), &H666666
Cls
'[ -- Label_frame text animation --
Var tic = 0.1
Var tici = .4
Var tic_text = 0
']

Do
    omb = mb
    
    GetMouse(mx, my, mz, mb)

    If ( Timer >= tic) Then
  If tic_text >= 20 Then tic_text = 0 Else tic_text +=1
  tic = Timer + tici
    EndIf
    
    key  = InKey
    se()
    
    Select Case Asc(key)
  Case 32 To 255
  s2 += key
    End Select

    screenlock
    Cls
    Draw String (10,10), s
    Draw String (10,30), s2
    Draw String ( tic_text * 20, 320), "Animate text"
    
    ScreenUnLock

    ok = key
    Sleep 1
    Flip
Loop Until MultiKey(&H01) Or InKey  = Chr(255)+"k"
While InKey <> "": Wend
End



Собственно нужно для interBox без прерывания цыкла

Код

/'
  input_box.bi
'/

#Undef __MAIN__
#Define __MAIN__ 1
#If __MAIN__
Dim Shared As Integer mx, my, mz, mb, omb
Const MYWHITE = RGB(255,255,255)
Const MYGREY = RGB(128,128,228)
Const MYDARKGREY2 = RGB(100,100,100)
Const MYBLACK = RGB(0,0,0)
#EndIf

#Undef midle
#Define midle( Out_x, Out_Width, in_Width) ( (Out_x) + ( (Out_Width) - (in_Width)) / 2)

#Undef MB_LEFT
#Define MB_LEFT 1

#Undef UP
#define UP 0
#Undef OVER
#define OVER 1
#Undef DOWN
#define DOWN 2
#Undef HIT
#define HIT 3
#Undef ENABLE
#define ENABLE 4

'#Undef LEFTE
'#define LEFTE 0
'#Undef CENTERE
'#define CENTERE 1
'#Undef RIGHTE
'#define RIGHTE 2

Type InputBox
    As Integer _
    x,_
    y,_
    w,_
    h,_
    bg(5),_
    fg,_
    bc,_
    over_color

    As boolean _
    hasMouse,_
    fixMouse,_
    enabled,_     ' Ëîãè÷åñêîå çíà÷åíèå, êîòîðîå îïðåäåëÿåò, âêëþ÷åíà ëè êíîïêà.
    toggle,_
    visible

    As String _
    text,_
    defaultText

    As ULong _
    textAlign     ' Âûðàâíèâàíèå òåêñòà ( LEFT, CENTER , RIGHT)

    Declare Constructor()
    Declare Constructor( x As Integer, y As Integer, w As Integer, text As string = "", defaultText As String = "")
    Declare Function event( old_mouse_button As Integer  = 0) As integer
    Declare Sub drawing()
    Declare Sub edit()
    Declare Function sendText( source_text_delete As boolean = false) As string

    Private:
    As String _
    txt

    As ULong _
    state

    As Integer _
    caret,_
    textStartAt,_
    max_char,_
    posX

    Declare Sub moveCaretLeft()
    Declare Sub moveCaretRight(  txt_ As String = "")
End Type

Sub InputBox.moveCaretLeft()
    If caret = 0 Then
  textStartAt -= 1
  If textStartAt < 1 Then textStartAt = 1
    Else
  caret -= 1
    EndIf
End Sub

Sub InputBox.moveCaretRight( txt_ As String = "")
    Var lenText = len(txt_)
    If caret = max_char Then
  If (caret + textStartAt) - lenText < 1 Then textStartAt += 1
  If lenText < 1 Then textStartAt = 1
    Else
  If ( lenText > 0) And (caret < lenText) Then caret += 1 ' If max_column > 0 Then
    End If
End Sub

Function InputBox.sendText( source_text_delete As boolean = false) As string
    Dim As String send_text = text
    If source_text_delete Then text = ""
    return send_text
End Function

Function InputBox.event( old_mouse_button As Integer  = 0) As Integer
    Dim As Integer res = 0, btn_, x_, y_
    GetMouse(x_, y_, , btn_)

    If visible Then
  With This
   If enabled Then
    .state = ENABLE
   Else
    If x_ >= .x And y_ >= .y And x_<=(.x + .w) And y_ <= (.y + .h) Then
     If ((btn_ And (MB_LEFT))<> 0) Then
      .state = DOWN
      .HasMouse = TRUE
      .fixMouse = true
      'res = 1
      'return 1
     Else
      If (((old_mouse_button And Not btn_) And (MB_LEFT))<>0) Then
       '.fixMouse = Not .fixMouse
       state = DOWN
       .HasMouse = TRUE
       return 1
      Else
       .state = OVER
       .HasMouse = TRUE
      EndIf
     EndIf
    ElseIf .hasMouse Then
     'If .fixMouse Then .state = DOWN Else .state = UP
     .hasMouse = FALSE
    Else
     .state = UP
     .hasMouse = FALSE
     .fixMouse = false
    EndIf
   EndIf
  End With
    EndIf

    Return res
End Function

Sub InputBox.drawing()
    If visible Then
  Select Case state
   Case UP
    Line( x, y) - (x + w - 1, y + h - 1), bg(0), bf
   Case OVER
    If fixMouse Then
     Line(x, y) - (x + w - 1, y + h - 1), bg(1), bf
    Else
     Line( x, y) - (x + w - 1, y + h - 1), bg(0), bf
    EndIf
    Line(x + 2, y + 2) - (x + w - 3, y + h - 3), over_color, b
   Case DOWN
    Line(x, y) - (x + w - 1, y + h - 1), bg(1), bf
    'Line(x + 2, y + 2) - (x + w - 3, y + h - 3), over_color, b
   Case HIT

   Case ENABLE
    Line(x, y) - (x + w - 1, y + h - 1), bg(2), bf
   Case Else
    Line(x, y) - (x + w - 1, y + h - 1), bg(1), bf
  End Select

  Line ( x, y) - ( x + w - 1, y + h - 1), bc, B
  Line ( x + 1, y + 1) - ( x + w - 2, y + 1), &H666666
  Line ( x + 1, y + h - 2) - ( x + w - 2, y + h - 2), &He6e6e6
  Line ( x + 1, y + 1) - ( x + 1, y + h - 2), &H666666
  Line ( x + w - 2, y + 1) - ( x + w - 2, y + h - 2), &He6e6e6

  If text = "" Then
   Draw String ( x + 5, midle( y + 2, h + 4, 14)), Mid( defaultText, 1, max_char),fg
  Else
   Draw String ( x + 5, midle( y + 2, h + 4, 14)), Mid( text, textStartAt, max_char),fg
  EndIf
    EndIf
End Sub

Sub InputBox.edit()
'[
Dim As Single _
caret_blink = 1.0,_
caret_interval = 1

Dim As String _
s,_
keystr,_
splitA,_
splitB

Dim As boolean _
triger_,_
keyUp,_
capet_visible,_
select_text,_
exitDo

Dim As Integer _
key,_
lenText,_
mx,_
my,_
mb,_
omb
']

state = HIT
s = text
If s = "" Then caret = 0

Do
'text = s '& Chr(32)    'caret End
lenText = len(s)
'[ Mouse & Keyboard event
keystr = inkey
If Len(keystr) = 1 Then key = Asc(keystr) Else key = 0

GetMouse mx, my,,mb
If mx >= x And my >= y And mx <=(x + w) And my <= (y + h) Then
    If ((mb And (MB_LEFT))<> 0) Then
  caret = (mx - x - 8) / 8
  If caret < 0 Then caret = 0
  If caret > lenText Then caret = lenText
    EndIf
Else
    If ((mb And (MB_LEFT))<> 0) Then Exit Do
EndIf
']

If keystr = ( Chr(255) & "S") Then ' Delete
    s = ""
    caret = 0
    textStartAt = 1
    posX = 0
ElseIf ( keystr = ( Chr(255) & "K") ) Then ' Left
    moveCaretLeft()
ElseIf ( keystr = ( Chr(255) & "M") ) Then ' Right
    moveCaretRight(s)
ElseIf ( keystr = (chr(255)+chr(71)) ) Then ' Home
    textStartAt = 1
    caret = 0
ElseIf ( keystr = (chr(255)+chr(79)) ) Then ' End
    If lenText < 1 Then
  textStartAt = 1
    ElseIf lenText > max_char then
  textStartAt += lenText - max_char
  caret = max_char
    EndIf

    If caret < 0 Then
  caret = 0
    ElseIf caret < max_char    Then
  caret = lenText
    Else
  caret = max_char
    EndIf
ElseIf ( keystr = chr(27)) And Not keyUp Then ' ESC
    keyUp = true
EndIf

If ( keystr <> chr(27)) And keyUp Then exitDo = true

Select Case key
    Case 13    'Enter
  Exit Do
    Case 8    'Backspace
  If ( len(s) > 0 ) And ( textStartAt >= 1) And ( caret > 0) Then
   splitA = Mid( s, 1, textStartAt + caret - 2)
   splitB = Mid( s, textStartAt + caret)
   s = splitA & splitB
   moveCaretLeft()
  EndIf
    Case 32 To 255
  splitA = Mid( s, 1, textStartAt + caret - 1)
  splitB = Mid( s, textStartAt + caret + 1 )
  s = splitA & keystr & splitB
  moveCaretRight(s)
End Select

If ( Timer >= caret_blink) Then
    capet_visible = Not capet_visible
    caret_blink = Timer + caret_interval
End If

ScreenLock()
#If __MAIN__
Line( 0,0) - ( 800, 200), &H333333, bf
#EndIf
Line( x, y) - ( x + w - 1, y + h - 1), bg(1), bf

Line ( x, y) - ( x + w - 1, y + h - 1), bc, B
Line ( x + 1, y + 1) - ( x + w - 2, y + 1), &H666666
Line ( x + 1, y + h - 2) - ( x + w - 2, y + h - 2), &Hcccccc
Line ( x + 1, y + 1) - ( x + 1, y + h - 2), &H666666
Line ( x + w - 2, y + 1) - ( x + w - 2, y + h - 2), &Hcccccc '&He6e6e6
Draw String ( x + 5, midle( y + 2, h + 4, 14)), Mid( s, textStartAt, max_char), fg ' Mid( s, 1, w / 8),fg

#If __MAIN__
Draw String ( 20,20), s
Draw String ( 10,40), "text: " & Str( lenText)
Draw String ( 10,60), "max_char: " & Str( max_char)
Draw String ( 100,40), "caret: " & Str(caret)
Draw String ( 200,60), "caret + textStartAt = " & Str(caret + textStartAt)
Draw String ( 260,40), "textStartAt: " & Str(textStartAt)
#endif

' draw caret
If capet_visible Then
    Line ( x + caret * 8 + 4 - posX * 8, y + 3)-( x + caret * 8 + 4 - posX * 8, y + 17), &H0a0a0a  
    Line ( x + caret * 8 + 4 - posX * 8 - 1, y + 3)-( x + caret * 8 + 4 - posX * 8 - 1, y + 17), &H0a0a0a  
EndIf
ScreenUnLock()

omb = mb
Sleep 1
Flip
Loop Until exitDo
While Inkey <> "": Wend

text = s
state = UP
End Sub

Constructor InputBox( x As Integer, y As Integer, w As Integer, text As String = "", defaultText As String = "")
    With This
  .x = x
  .y = y
  .w = w
  .h = 20
  .text = text
  .defaultText = defaultText
  .textAlign = 0
  .fg = &H666666
  .bc = &H000000
  .bg(0) = &Hb3b3b3
  .bg(1) = &Hffffff
  .bg(2) = &H333333
  .over_color = &H32dcff
  .visible = true
  .textStartAt = 1
  .max_char = ( w - 8) / 8
    End With
End Constructor

Constructor InputBox()
    h = 20
    textStartAt = 1
End Constructor

'/'
'===============================================
#If __MAIN__
'
ScreenRes 800, 600, 32, 2
ScreenSet 1, 0
Color RGB(255, 128, 0), &H666666
Cls

Dim As InputBox ib = InputBox( 100, 100, 200,,"input text ...")

'[ -- Label_frame text animation --
Var tic = 0.1
Var tici = .4
Var tic_text = 0
']

Do
    omb = mb
    GetMouse(mx, my, mz, mb)

    If ( Timer >= tic) Then
  If tic_text >= 20 Then tic_text = 0 Else tic_text +=1
  tic = Timer + tici
    EndIf
    
    If ib.event(omb) Then ib.edit

    screenlock
    Cls
    Draw String ( 20,20), ib.text
    Draw String ( tic_text * 20, 320), "Animate text"
    ib.drawing
    ScreenUnLock

    Sleep 25
    Flip
Loop Until MultiKey(&H01) Or InKey  = Chr(255)+"k"
While InKey <> "": Wend
End
#EndIf
'/


посоветуйте чего-нибудь, а ?
пробовал использовать
Код

If GetAsyncKeyState(32) Then : key_pressed = 32

но геморно


polopok
 
haavДата: Пятница, 07.07.2023, 06:25 | Сообщение # 2
Генералиссимус
Группа: Администраторы
Сообщений: 1366
Репутация: 49
Статус: Offline
Слишком много вызовов INKEY. Убери хотя бы в конце и все будет выводится:

Код
Loop Until MultiKey(&H01)


опрос клавиатуры с помощью INKEY/GETKEY делают один раз и потом пользуются результатами.
Я сейчас точно не помню насчет GETKEY.
Но INKEY абсолютно точно подтирает за собой буфер.


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
ntvgjhfnjДата: Пятница, 07.07.2023, 11:09 | Сообщение # 3
Лейтенант
Группа: Проверенные
Сообщений: 61
Репутация: 1
Статус: Offline
Спасибо! rah
код подправил заработало
Код

Dim Shared As Integer mx, my, mz, mb, omb
Dim Shared As String key, s, s2, ok

Sub se()
    Select Case Asc(key)
  Case 32 To 255
  s += key
    End Select
End Sub

'
ScreenRes 800, 600, 32, 2
ScreenSet 1, 0
Color RGB(255, 128, 0), &H666666
Cls
'[ -- Label_frame text animation --
Var tic = 0.1
Var tici = .4
Var tic_text = 0
']

Do
    omb = mb
    
    GetMouse(mx, my, mz, mb)

    If ( Timer >= tic) Then
  If tic_text >= 20 Then tic_text = 0 Else tic_text +=1
  tic = Timer + tici
    EndIf
    
    key  = InKey
    se()
    
    'Select Case Asc(key)
    '    Case 32 To 255
    '    s2 += key
    'End Select

    screenlock
    Cls
    Draw String (10,10), s
    Draw String (10,30), s2
    Draw String ( tic_text * 20, 320), "Animate text"
    
    ScreenUnLock

    ok = key
    Sleep 1
    Flip
Loop Until MultiKey(&H01) Or Key  = Chr(255)+"k"
While InKey <> "": Wend
End


polopok
 
  • Страница 1 из 1
  • 1
Поиск: