Статьи

Листинг к статье

"Как написать игрушку на VB"

Модуль: mdlAuto

Option Explicit

Public Declare Function StretchBlt Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal nSrcWidth As Long, _
    ByVal nSrcHeight As Long, _
    ByVal dwRop As Long) _
As Long

Public Type POINTAPI

    x As Long

    y As Long

End Type

Public Enum constTypeOptions

    GetOption = 0

    SaveOption = 1

End Enum

Public Enum constKeyOptions

    MaxSpeed = 0

    Time = 1

    AutoUp = 2

    AutoDown = 3

End Enum

Public Const SRCCOPY = &HCC0020

Public Auto As POINTAPI

Public OtherAuto(0 To 11) As POINTAPI ' от 0 до 5 - навстречу,
                                      ' от 6 до 11 - по ходу

Public Speed As Integer

Public Sub Main()

'проверка на самое первое открытие игры,
'в случае необходимости пишем в реестр

If Options(GetOption, Time) = vbNullString Then

    Options SaveOption, AutoDown, 6

    Options SaveOption, AutoUp, 6

    Options SaveOption, MaxSpeed, 300

    Options SaveOption, Time, "0:01:00"

End If

With frmMain

    'позиционируем наше авто

    Auto.x = .picRoad.Width * 0.75

    Auto.y = .picRoad.Height * 0.5

    'просчитываем координаты других авто

    RndAuto

    .Show

    .RedrawPic

End With

End Sub

Public Sub RndAuto()

Dim i%

With frmMain

    Randomize

    For i = 0 To Options(GetOption, AutoDown) - 1 'для встречных
        'добавляется по 2 пиксела к 23 для расстояния между машинами

        OtherAuto(i).x = (i * 25) + (.picRoad.Width * 0.05)

        OtherAuto(i).y = Int((.picRoad.Height + 1) * Rnd)

    Next

    For i = 6 To Options(GetOption, AutoUp) + 5 'для попутных
        'добавляется по 2 пиксела к 23 для расстояния между машинами

        OtherAuto(i).x = ((i - 6) * 25) + (.picRoad.Width * 0.5)

        OtherAuto(i).y = Int((.picRoad.Height + 1) * Rnd)

    Next

End With

End Sub

'упрощение доступа к реестру

Public Function Options(ByVal TypeOptions As constTypeOptions, _
    ByVal Key As constKeyOptions, Optional Setting As String) As String

Select Case TypeOptions

Case GetOption 'считывание

    Options = GetSetting(App.EXEName, "Options", Key)

Case SaveOption 'запись

    SaveSetting App.EXEName, "Options", Key, Setting

End Select

End Function

Форма: frmMain

Option Explicit

Private Sub Form_Load()

    'обновляем значения, согласно сохраненному в реестре

    lblTime.Caption = Options(GetOption, Time)

    Speedometr1.Max = Options(GetOption, MaxSpeed)

End Sub

Private Sub mnuExit_Click()

    Unload Me

End Sub

Private Sub mnuNew_Click()

    'новая игра, запускаем таймеры

    tmrMove.Enabled = True

    tmrTime.Enabled = True

End Sub

Private Sub mnuOptions_Click()

'запуск формы настроек

    frmOption.Show vbModal

End Sub

Private Sub picRoad_KeyDown(KeyCode As Integer, Shift As Integer)

Select Case KeyCode

Case vbKeyLeft 'смещение влево

    If Auto.x <= picRoad.Width * 0.05 Then Exit Sub

    Auto.x = Auto.x - 2

Case vbKeyRight 'смещение вправо

    If Auto.x >= picRoad.Width * 0.95 - 23 Then Exit Sub

    Auto.x = Auto.x + 2

Case vbKeyUp 'увеличение скорости

    Speed = Speed + 1

    If Speed * 20 > Options(GetOption, MaxSpeed) Then _
        Speed = Options(GetOption, MaxSpeed) / 20

    lblSpeed.Caption = Speed * 20

    Speedometr1.Value = Speed * 20

Case vbKeyDown 'уменьшение скорости

    Speed = Speed - 1

    If Speed < 0 Then Speed = 0

    lblSpeed.Caption = Speed * 20

    Speedometr1.Value = Speed * 20

End Select

End Sub

Public Sub DrawRoad()

    'Рисуем:
    'левый зеленый бордюр

    picRoad.Line (0, 0)-(picRoad.Width * 0.05, picRoad.Height), vbGreen, BF

    'правый зеленый бордюр

    picRoad.Line (picRoad.Width * 0.95, 0)-(picRoad.Width, picRoad.Height), _
        vbGreen, BF

    'дорога

    picRoad.Line (picRoad.Width * 0.05, 0)-(picRoad.Width * 0.95, _
        picRoad.Height), vbBlack, BF

    'осевая линия

    picRoad.Line (picRoad.Width * 0.5, 0)-(picRoad.Width * 0.5, _
        picRoad.Height), vbYellow, BF

End Sub

Public Sub DrawAuto()

    'копируем наше авто из общей картинки на дорогу

    StretchBlt picRoad.hdc, Auto.x, Auto.y, _
        23, 31, picSrc.hdc, 0, 0, 23, 31, SRCCOPY

End Sub

'Перерисовка всей графики

Public Sub RedrawPic()

Dim i%

    DrawRoad

    DrawAuto

    'встречные авто

    For i = 0 To Options(GetOption, AutoDown) - 1

        DrawOtherAuto i

    Next

    'попутные авто

    For i = 6 To Options(GetOption, AutoUp) + 5

        DrawOtherAuto i

    Next

End Sub

'копируем прочие авто из общей картинки на дорогу

Public Sub DrawOtherAuto(Num As Integer)

    Select Case Num

    Case 0 To 5 'встречные

    StretchBlt picRoad.hdc, OtherAuto(Num).x, OtherAuto(Num).y, _
        23, 31, picSrc.hdc, Num * 23, 31, 23, 31, SRCCOPY

    Case 6 To 11 'попутные

    StretchBlt picRoad.hdc, OtherAuto(Num).x, OtherAuto(Num).y, _
        23, 31, picSrc.hdc, (Num - 6) * 23, 62, 23, 31, SRCCOPY

    End Select

End Sub

Private Sub tmrMove_Timer()

Dim i%

'для встречных авто

For i = 0 To Options(GetOption, AutoDown) - 1

    'если выходит за край картинки дороги

    If OtherAuto(i).y >= picRoad.Height Then

        OtherAuto(i).y = -31

    ElseIf OtherAuto(i).y <= -31 Then

        OtherAuto(i).y = picRoad.Height

    End If

    '+2 - смещение на 2 пиксела

    OtherAuto(i).y = OtherAuto(i).y + 2 + i + Speed

Next

'для попутных авто

For i = 6 To Options(GetOption, AutoUp) + 5

    'если выходит за край картинки дороги

    If OtherAuto(i).y >= picRoad.Height Then

        OtherAuto(i).y = -31

    ElseIf OtherAuto(i).y <= -31 Then

        OtherAuto(i).y = picRoad.Height

    End If

    '-2 - смещение на 2 пиксела

    OtherAuto(i).y = OtherAuto(i).y - 2 - (13 - i) + Speed

Next

    'проверка на аварию

    Crash

    'пройденное расстояние

    lblPath.Caption = lblPath.Caption + (lblSpeed.Caption * 0.01)

    RedrawPic

End Sub

Private Sub Crash()

Dim i%

For i = 0 To 11

'при совпадении координат
    'по вертикали

    If ((Auto.y + 31 >= OtherAuto(i).y) And _
        (Auto.y + 31 <= OtherAuto(i).y + 31)) Or _
        ((Auto.y >= OtherAuto(i).y) And _
        (Auto.y <= OtherAuto(i).y + 31)) Then

        '+ по горизонтали

        If ((Auto.x + 23 >= OtherAuto(i).x) And _
            (Auto.x + 23 <= OtherAuto(i).x + 23)) Or _
            ((Auto.x >= OtherAuto(i).x) And _
            (Auto.x <= OtherAuto(i).x + 23)) Then

           

            'обнуляем скорость нашего авто

            Speed = 0

            lblSpeed.Caption = "0"

            Speedometr1.Value = 0

        End If

    End If

Next

End Sub

'отсчет времени игры

Private Sub tmrTime_Timer()

lblTime.Caption = CDate(CDate(lblTime.Caption) - CDate("0:00:01"))

If lblTime.Caption = "0:00:00" Then 'если время истекло

    tmrMove.Enabled = False

    tmrTime.Enabled = False

    MsgBox "Пройденное расстояние - " & lblPath.Caption & " км.", _
        vbInformation + vbOKOnly, "Игра закончена"

    lblSpeed.Caption = "0"

    lblPath.Caption = "0"

    lblTime.Caption = Options(GetOption, Time)

    Speedometr1.Value = 0

    Speed = 0

End If

End Sub

Форма: frmOption

Option Explicit

Private Sub cmdOKCancel_Click(Index As Integer)

Select Case Index

Case 0 'если ОК - сохраняемся в реестре

    'проверка на правильность введения времени

    If Not IsDate(txtTime.Text) Then

        MsgBox "В поле не время!", vbExclamation, "Ошибка!"

        Exit Sub

    End If

    Options SaveOption, Time, txtTime.Text

    Options SaveOption, MaxSpeed, txtMaxSpeed.Text

    Options SaveOption, AutoUp, CStr(cboNumAuto(0).ListIndex)

    Options SaveOption, AutoDown, CStr(cboNumAuto(1).ListIndex)

End Select

'закрытие формы

Unload Me

End Sub

Private Sub Form_Load()

'считывание данных в поля формы

    txtTime.Text = Options(GetOption, Time)

    txtMaxSpeed.Text = Options(GetOption, MaxSpeed)

    cboNumAuto(0).ListIndex = Options(GetOption, AutoUp)

    cboNumAuto(1).ListIndex = Options(GetOption, AutoDown)

End Sub

Private Sub Form_Unload(Cancel As Integer)

'передача данных в основную форму

    With frmMain

        .lblTime.Caption = Options(GetOption, Time)

        .Speedometr1.Max = Options(GetOption, MaxSpeed)

        'изменение координат авто, в зависимости от
        'количества выбранных нами

        RndAuto

        'перерисовка графики

        .RedrawPic

    End With

End Sub

'ограничение ввода в текстовые поля

Private Sub txtMaxSpeed_KeyPress(KeyAscii As Integer)

Select Case KeyAscii

Case 8, 48 To 57 'backspace + цифры от 0 до 9

Case Else 'ничего не выводим

    Beep

    KeyAscii = 0

End Select

End Sub

Private Sub txtTime_KeyPress(KeyAscii As Integer)

Select Case KeyAscii

Case 8, 48 To 57, 58 'backspace + цифры от 0 до 9 + двоеточие

Case Else 'ничего не выводим

    Beep

    KeyAscii = 0

End Select

End Sub

UserControl: Speedometr

Option Explicit

'Значения для внутренних переменных по-умолчанию:

Const m_def_ArrowColor = 0

Const m_def_Min = 0

Const m_def_Max = 100

Const m_def_Value = 0

'Объявление внутренних переменных:

Dim m_ArrowColor As OLE_COLOR

Dim m_Min As Long

Dim m_Max As Long

Dim m_Value As Long

'Свойства

Public Property Get Value() As Long

    Value = m_Value

End Property

Public Property Let Value(ByVal New_Value As Long)

    m_Value = New_Value

    PropertyChanged "Value"

    Draw

End Property

Public Property Get Min() As Long

    Min = m_Min

End Property

Public Property Let Min(ByVal New_Min As Long)

    m_Min = New_Min

    PropertyChanged "Min"

    'здесь мы не объявляем процедуру Draw,
    'т.к. при изменении этого свойства
    'перерисовки графики не требуется

End Property

Public Property Get Max() As Long

    Max = m_Max

End Property

Public Property Let Max(ByVal New_Max As Long)

    m_Max = New_Max

    PropertyChanged "Max"

    'здесь мы не объявляем процедуру Draw,
    'т.к. при изменении этого свойства
    'перерисовки графики не требуется

End Property

Public Property Get BackColor() As OLE_COLOR

    BackColor = UserControl.BackColor

End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)

    UserControl.BackColor() = New_BackColor

    PropertyChanged "BackColor"

    Draw

End Property

Public Property Get ArrowColor() As OLE_COLOR

    ArrowColor = m_ArrowColor

End Property

Public Property Let ArrowColor(ByVal New_ArrowColor As OLE_COLOR)

    m_ArrowColor = New_ArrowColor

    PropertyChanged "ArrowColor"

    Draw

End Property

Public Property Get ConturColor() As OLE_COLOR

    ConturColor = UserControl.FillColor

End Property

Public Property Let ConturColor(ByVal New_ConturColor As OLE_COLOR)

    UserControl.FillColor() = New_ConturColor

    PropertyChanged "ConturColor"

    Draw

End Property

Public Property Get ArrowWidth() As Integer

    ArrowWidth = UserControl.DrawWidth

End Property

Public Property Let ArrowWidth(ByVal New_ArrowWidth As Integer)

    UserControl.DrawWidth() = New_ArrowWidth

    PropertyChanged "ArrowWidth"

    Draw

End Property

'Инициализация свойств контрола

Private Sub UserControl_InitProperties()

    m_Min = m_def_Min

    m_Max = m_def_Max

    m_Value = m_def_Value

    m_ArrowColor = m_def_ArrowColor

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_Min = PropBag.ReadProperty("Min", m_def_Min)

    m_Max = PropBag.ReadProperty("Max", m_def_Max)

    m_Value = PropBag.ReadProperty("Value", m_def_Value)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)

    m_ArrowColor = PropBag.ReadProperty("ArrowColor", m_def_ArrowColor)

    UserControl.FillColor = PropBag.ReadProperty("ConturColor", &HFFFFC0)

    UserControl.DrawWidth = PropBag.ReadProperty("ArrowWidth", 2)

End Sub

Private Sub UserControl_Show()

'перерисовка графики при запуске контрола

    Draw

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Min", m_Min, m_def_Min)

    Call PropBag.WriteProperty("Max", m_Max, m_def_Max)

    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, _
        &H8000000F)

    Call PropBag.WriteProperty("ArrowColor", m_ArrowColor, m_def_ArrowColor)

    Call PropBag.WriteProperty("ConturColor", UserControl.FillColor, _
        &HFFFFC0)

    Call PropBag.WriteProperty("ArrowWidth", UserControl.DrawWidth, 2)

End Sub

Private Sub Draw()

    Cls

    Line (0, 0)-(ScaleWidth, ScaleHeight * 0.1), ConturColor, BF

    Circle (ScaleWidth * 0.5, ScaleHeight), ScaleHeight * 0.1, ConturColor

    'стрелка спидометра

    Line (ScaleWidth * 0.5, ScaleHeight)-(ScaleWidth * (m_Value-m_Min) / _
        (m_Max - m_Min), 0), m_ArrowColor

End Sub

К статье

Hosted by uCoz