FreeBasic
Главная
Вход
Регистрация
Понедельник, 30.12.2024, 18:55Приветствую Вас Гость | RSS
[ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
  • Страница 1 из 1
  • 1
Часы
haavДата: Воскресенье, 19.08.2012, 18:59 | Сообщение # 1
Генералиссимус
Группа: Администраторы
Сообщений: 1373
Репутация: 50
Статус: Offline
Часы


Обычные часы , но вывод как у индикаторов электронных часов (см. скриншот ниже).

Авторство неизвестно.



Code

Screen 18, 32, 2

Declare Sub MT (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub M (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub MB (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub LT (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub LB (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub RT (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub RB (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)

Declare Sub DrawDigit (ByVal tx As Integer, ByVal ty As Integer, ByVal ds As String, ByVal d As Integer)
Declare Sub DrawDot (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
Declare Sub DrawTimer (ByVal tx As Integer, ByVal ty As Integer, ByVal st As String)

Dim As Integer red = &hDD3C3C', yell = &hF0DD40
Dim As Integer i, j, k, stx = 35, sty = 180
Dim Shared As Any ptr vrt_red, hrz_red, dot
Dim As String sstr1, sstr2, sstr3, tt

vrt_red = ImageCreate (10,60,,32)
hrz_red = ImageCreate (50,10,,32)
dot = ImageCreate (10,10,,32)

Draw hrz_red, "BM0,4 C" & red & "E4 R40 F4 D1 G4 L40 H4 U1"
Paint hrz_red, (5,5), red, red

Draw vrt_red, "A3 BM5,0 C" & red & "E4 R50 F4 D1 G4 L50 H4 U1"
Paint vrt_red, (5,5), red, red

Line dot, (0,0)-(10,10), red, BF

Do
         ScreenSet 2, 1
         DrawTimer (stx, sty, Time)
         Flip
         tt = Time
         Do
                 Sleep 5, 1
                 If MultiKey (&h01) Or InKey = Chr(255)+"k" Then Exit Do, Do
                 If tt <> Time Then Exit Do
         Loop
         Cls
         If MultiKey (&h01) Or InKey = Chr(255)+"k" Then Exit Do
Loop

ImageDestroy (vrt_red)
ImageDestroy (hrz_red)
ImageDestroy (dot)

Sub MT (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (8+tx+d,ty), hrz_red, TRANS
End Sub

Sub M (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (8+tx+d,65+ty), hrz_red, TRANS
End Sub

Sub MB (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (8+tx+d,130+ty), hrz_red, TRANS
End Sub

Sub LT (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (tx+d,8+ty), vrt_red, TRANS
End Sub

Sub LB (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (tx+d,73+ty), vrt_red, TRANS
End Sub

Sub RT (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (55+tx+d,8+ty), vrt_red, TRANS
End Sub

Sub RB (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (55+tx+d,73+ty), vrt_red, TRANS
End Sub

Sub DrawDigit (ByVal tx As Integer, ByVal ty As Integer, ByVal ds As String, ByVal d As Integer)
         Select Case ds
                 Case "0"
                         MT (tx,ty,d)
                         MB (tx,ty,d)
                         LT (tx,ty,d)
                         LB (tx,ty,d)
                         RT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "1"
                         RT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "2"
                         MT (tx,ty,d)
                         M (tx,ty,d)
                         MB (tx,ty,d)
                         LB (tx,ty,d)
                         RT (tx,ty,d)
                 Case "3"
                         MT (tx,ty,d)
                         M (tx,ty,d)
                         MB (tx,ty,d)
                         RT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "4"
                         M (tx,ty,d)
                         LT (tx,ty,d)
                         RT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "5"
                         MT (tx,ty,d)
                         M (tx,ty,d)
                         MB (tx,ty,d)
                         LT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "6"
                         MT (tx,ty,d)
                         M (tx,ty,d)
                         MB (tx,ty,d)
                         LT (tx,ty,d)
                         LB (tx,ty,d)
                         RB (tx,ty,d)
                 Case "7"
                         MT (tx,ty,d)
                         RT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "8"
                         MT (tx,ty,d)
                         M (tx,ty,d)
                         MB (tx,ty,d)
                         LT (tx,ty,d)
                         LB (tx,ty,d)
                         RT (tx,ty,d)
                         RB (tx,ty,d)
                 Case "9"
                         MT (tx,ty,d)
                         M (tx,ty,d)
                         MB (tx,ty,d)
                         LT (tx,ty,d)
                         RT (tx,ty,d)
                         RB (tx,ty,d)
         End Select
End Sub

Sub DrawDot (ByVal tx As Integer, ByVal ty As Integer, ByVal d As Integer)
         Put (75+tx+d,32+ty), dot, TRANS
         Put (75+tx+d,98+ty), dot, TRANS
End Sub

Sub DrawTimer (ByVal tx As Integer, ByVal ty As Integer, ByVal st As String)
         Dim As Integer P1 = 0, P2 = 90, P3 = 205, P4 = 295, P5 = 410, P6 = 500, DT1 = 100, DT2 = 305
         DrawDigit (tx,ty,Mid(st,1,1),P1)
         DrawDigit (tx,ty,Mid(st,2,1),P2)
         DrawDot (tx,ty,DT1)
         DrawDigit (tx,ty,Mid(st,4,1),P3)
         DrawDigit (tx,ty,Mid(st,5,1),P4)
         DrawDot (tx,ty,DT2)
         DrawDigit (tx,ty,Mid(st,7,1),P5)
         DrawDigit (tx,ty,Mid(st,8,1),P6)
End Sub
Прикрепления: 9967758.png (27.6 Kb)


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
  • Страница 1 из 1
  • 1
Поиск: